{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CoreToStg.Prep
( corePrepPgm
, corePrepExpr
, mkConvertNumLiteral
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Platform.Ways
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Driver.Ppr
import GHC.Tc.Utils.Env
import GHC.Unit
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Types.Id.Make ( realWorldPrimId )
import GHC.Core.Utils
import GHC.Core.Opt.Arity
import GHC.Core.FVs
import GHC.Core.Opt.Monad ( CoreToDo(..) )
import GHC.Core.Lint ( endPassIO )
import GHC.Core
import GHC.Core.Make hiding( FloatBind(..) )
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Opt.OccurAnal
import GHC.Core.TyCo.Rep( UnivCoProvenance(..) )
import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.FastString
import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Utils.Monad ( mapAccumLM )
import GHC.Utils.Logger
import GHC.Types.Demand
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Basic
import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName )
import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
import GHC.Types.Literal
import GHC.Types.Tickish
import GHC.Types.TyThing
import GHC.Types.CostCentre ( CostCentre, ccFromThisModule )
import GHC.Types.Unique.Supply
import GHC.Data.Pair
import Data.List ( unfoldr )
import Data.Functor.Identity
import Control.Monad
import qualified Data.Set as S
type CpeArg = CoreExpr
type CpeApp = CoreExpr
type CpeBody = CoreExpr
type CpeRhs = CoreExpr
corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
-> IO (CoreProgram, S.Set CostCentre)
corePrepPgm :: HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO (CoreProgram, Set CostCentre)
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
mod_loc CoreProgram
binds [TyCon]
data_tycons =
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags
(String -> SDoc
text String
"CorePrep"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(\(CoreProgram
a,Set CostCentre
b) -> CoreProgram
a forall a b. [a] -> b -> b
`seqList` Set CostCentre
b seq :: forall a b. a -> b -> b
`seq` ()) forall a b. (a -> b) -> a -> b
$ do
UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
's'
CorePrepEnv
initialCorePrepEnv <- HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv HscEnv
hsc_env
let cost_centres :: Set CostCentre
cost_centres
| Way
WayProf forall a. Ord a => a -> Set a -> Bool
`S.member` DynFlags -> Ways
ways DynFlags
dflags
= Module -> CoreProgram -> Set CostCentre
collectCostCentres Module
this_mod CoreProgram
binds
| Bool
otherwise
= forall a. Set a
S.empty
implicit_binds :: CoreProgram
implicit_binds = DynFlags -> ModLocation -> [TyCon] -> CoreProgram
mkDataConWorkers DynFlags
dflags ModLocation
mod_loc [TyCon]
data_tycons
binds_out :: CoreProgram
binds_out = forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us forall a b. (a -> b) -> a -> b
$ do
Floats
floats1 <- CorePrepEnv -> CoreProgram -> UniqSM Floats
corePrepTopBinds CorePrepEnv
initialCorePrepEnv CoreProgram
binds
Floats
floats2 <- CorePrepEnv -> CoreProgram -> UniqSM Floats
corePrepTopBinds CorePrepEnv
initialCorePrepEnv CoreProgram
implicit_binds
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> CoreProgram
deFloatTop (Floats
floats1 Floats -> Floats -> Floats
`appendFloats` Floats
floats2))
HscEnv
-> PrintUnqualified
-> CoreToDo
-> CoreProgram
-> [CoreRule]
-> IO ()
endPassIO HscEnv
hsc_env PrintUnqualified
alwaysQualify CoreToDo
CorePrep CoreProgram
binds_out []
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreProgram
binds_out, Set CostCentre
cost_centres)
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr :: HscEnv -> CpeBody -> IO CpeBody
corePrepExpr HscEnv
hsc_env CpeBody
expr = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags (String -> SDoc
text String
"CorePrep [expr]") (\CpeBody
e -> CpeBody
e seq :: forall a b. a -> b -> b
`seq` ()) forall a b. (a -> b) -> a -> b
$ do
UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
's'
CorePrepEnv
initialCorePrepEnv <- HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv HscEnv
hsc_env
let new_expr :: CpeBody
new_expr = forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (CorePrepEnv -> CpeBody -> UniqSM CpeBody
cpeBodyNF CorePrepEnv
initialCorePrepEnv CpeBody
expr)
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_prep String
"CorePrep" DumpFormat
FormatCore (forall a. Outputable a => a -> SDoc
ppr CpeBody
new_expr)
forall (m :: * -> *) a. Monad m => a -> m a
return CpeBody
new_expr
corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
corePrepTopBinds :: CorePrepEnv -> CoreProgram -> UniqSM Floats
corePrepTopBinds CorePrepEnv
initialCorePrepEnv CoreProgram
binds
= CorePrepEnv -> CoreProgram -> UniqSM Floats
go CorePrepEnv
initialCorePrepEnv CoreProgram
binds
where
go :: CorePrepEnv -> CoreProgram -> UniqSM Floats
go CorePrepEnv
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return Floats
emptyFloats
go CorePrepEnv
env (CoreBind
bind : CoreProgram
binds) = do (CorePrepEnv
env', Floats
floats, Maybe CoreBind
maybe_new_bind)
<- TopLevelFlag
-> CorePrepEnv
-> CoreBind
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
cpeBind TopLevelFlag
TopLevel CorePrepEnv
env CoreBind
bind
MASSERT(isNothing maybe_new_bind)
Floats
floatss <- CorePrepEnv -> CoreProgram -> UniqSM Floats
go CorePrepEnv
env' CoreProgram
binds
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats Floats -> Floats -> Floats
`appendFloats` Floats
floatss)
mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> CoreProgram
mkDataConWorkers DynFlags
dflags ModLocation
mod_loc [TyCon]
data_tycons
= [ forall b. b -> Expr b -> Bind b
NonRec Id
id (Name -> CpeBody -> CpeBody
tick_it (forall a. NamedThing a => a -> Name
getName DataCon
data_con) (forall b. Id -> Expr b
Var Id
id))
| TyCon
tycon <- [TyCon]
data_tycons,
DataCon
data_con <- TyCon -> [DataCon]
tyConDataCons TyCon
tycon,
let id :: Id
id = DataCon -> Id
dataConWorkId DataCon
data_con
]
where
tick_it :: Name -> CpeBody -> CpeBody
tick_it Name
name
| Bool -> Bool
not (DynFlags -> Bool
needSourceNotes DynFlags
dflags) = forall a. a -> a
id
| RealSrcSpan RealSrcSpan
span Maybe BufSpan
_ <- Name -> SrcSpan
nameSrcSpan Name
name = RealSrcSpan -> CpeBody -> CpeBody
tick RealSrcSpan
span
| Just String
file <- ModLocation -> Maybe String
ml_hs_file ModLocation
mod_loc = RealSrcSpan -> CpeBody -> CpeBody
tick (String -> RealSrcSpan
span1 String
file)
| Bool
otherwise = RealSrcSpan -> CpeBody -> CpeBody
tick (String -> RealSrcSpan
span1 String
"???")
where tick :: RealSrcSpan -> CpeBody -> CpeBody
tick RealSrcSpan
span = forall b. CoreTickish -> Expr b -> Expr b
Tick (forall (pass :: TickishPass).
RealSrcSpan -> String -> GenTickish pass
SourceNote RealSrcSpan
span forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (forall a. Outputable a => a -> SDoc
ppr Name
name))
span1 :: String -> RealSrcSpan
span1 String
file = RealSrcLoc -> RealSrcSpan
realSrcLocSpan forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
file) Int
1 Int
1
cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
-> UniqSM (CorePrepEnv,
Floats,
Maybe CoreBind)
cpeBind :: TopLevelFlag
-> CorePrepEnv
-> CoreBind
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
cpeBind TopLevelFlag
top_lvl CorePrepEnv
env (NonRec Id
bndr CpeBody
rhs)
| Bool -> Bool
not (Id -> Bool
isJoinId Id
bndr)
= do { (CorePrepEnv
env1, Id
bndr1) <- CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env Id
bndr
; let dmd :: Demand
dmd = Id -> Demand
idDemandInfo Id
bndr
is_unlifted :: Bool
is_unlifted = HasDebugCallStack => Type -> Bool
isUnliftedType (Id -> Type
idType Id
bndr)
; (Floats
floats, CpeBody
rhs1) <- TopLevelFlag
-> RecFlag
-> Demand
-> Bool
-> CorePrepEnv
-> Id
-> CpeBody
-> UniqSM (Floats, CpeBody)
cpePair TopLevelFlag
top_lvl RecFlag
NonRecursive
Demand
dmd Bool
is_unlifted
CorePrepEnv
env Id
bndr1 CpeBody
rhs
; let triv_rhs :: Bool
triv_rhs = CpeBody -> Bool
exprIsTrivial CpeBody
rhs1
env2 :: CorePrepEnv
env2 | Bool
triv_rhs = CorePrepEnv -> Id -> CpeBody -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
env1 Id
bndr CpeBody
rhs1
| Bool
otherwise = CorePrepEnv
env1
floats1 :: Floats
floats1 | Bool
triv_rhs, Name -> Bool
isInternalName (Id -> Name
idName Id
bndr)
= Floats
floats
| Bool
otherwise
= Floats -> FloatingBind -> Floats
addFloat Floats
floats FloatingBind
new_float
new_float :: FloatingBind
new_float = Demand -> Bool -> Id -> CpeBody -> FloatingBind
mkFloat Demand
dmd Bool
is_unlifted Id
bndr1 CpeBody
rhs1
; forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv
env2, Floats
floats1, forall a. Maybe a
Nothing) }
| Bool
otherwise
= ASSERT(not (isTopLevel top_lvl))
do { (CorePrepEnv
_, Id
bndr1) <- CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env Id
bndr
; (Id
bndr2, CpeBody
rhs1) <- CorePrepEnv -> Id -> CpeBody -> UniqSM (Id, CpeBody)
cpeJoinPair CorePrepEnv
env Id
bndr1 CpeBody
rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env Id
bndr Id
bndr2,
Floats
emptyFloats,
forall a. a -> Maybe a
Just (forall b. b -> Expr b -> Bind b
NonRec Id
bndr2 CpeBody
rhs1)) }
cpeBind TopLevelFlag
top_lvl CorePrepEnv
env (Rec [(Id, CpeBody)]
pairs)
| Bool -> Bool
not (Id -> Bool
isJoinId (forall a. [a] -> a
head [Id]
bndrs))
= do { (CorePrepEnv
env', [Id]
bndrs1) <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
; [(Floats, CpeBody)]
stuff <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TopLevelFlag
-> RecFlag
-> Demand
-> Bool
-> CorePrepEnv
-> Id
-> CpeBody
-> UniqSM (Floats, CpeBody)
cpePair TopLevelFlag
top_lvl RecFlag
Recursive Demand
topDmd Bool
False CorePrepEnv
env')
[Id]
bndrs1 [CpeBody]
rhss
; let ([Floats]
floats_s, [CpeBody]
rhss1) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Floats, CpeBody)]
stuff
all_pairs :: [(Id, CpeBody)]
all_pairs = forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> [(Id, CpeBody)] -> [(Id, CpeBody)]
add_float ([Id]
bndrs1 forall a b. [a] -> [b] -> [(a, b)]
`zip` [CpeBody]
rhss1)
([Floats] -> OrdList FloatingBind
concatFloats [Floats]
floats_s)
; forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
extendCorePrepEnvList CorePrepEnv
env ([Id]
bndrs forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
bndrs1),
FloatingBind -> Floats
unitFloat (CoreBind -> FloatingBind
FloatLet (forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CpeBody)]
all_pairs)),
forall a. Maybe a
Nothing) }
| Bool
otherwise
= do { (CorePrepEnv
env', [Id]
bndrs1) <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
; [(Id, CpeBody)]
pairs1 <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (CorePrepEnv -> Id -> CpeBody -> UniqSM (Id, CpeBody)
cpeJoinPair CorePrepEnv
env') [Id]
bndrs1 [CpeBody]
rhss
; let bndrs2 :: [Id]
bndrs2 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Id, CpeBody)]
pairs1
; forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
extendCorePrepEnvList CorePrepEnv
env' ([Id]
bndrs forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
bndrs2),
Floats
emptyFloats,
forall a. a -> Maybe a
Just (forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CpeBody)]
pairs1)) }
where
([Id]
bndrs, [CpeBody]
rhss) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CpeBody)]
pairs
add_float :: FloatingBind -> [(Id, CpeBody)] -> [(Id, CpeBody)]
add_float (FloatLet (NonRec Id
b CpeBody
r)) [(Id, CpeBody)]
prs2 = (Id
b,CpeBody
r) forall a. a -> [a] -> [a]
: [(Id, CpeBody)]
prs2
add_float (FloatLet (Rec [(Id, CpeBody)]
prs1)) [(Id, CpeBody)]
prs2 = [(Id, CpeBody)]
prs1 forall a. [a] -> [a] -> [a]
++ [(Id, CpeBody)]
prs2
add_float FloatingBind
b [(Id, CpeBody)]
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cpeBind" (forall a. Outputable a => a -> SDoc
ppr FloatingBind
b)
cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
-> CorePrepEnv -> OutId -> CoreExpr
-> UniqSM (Floats, CpeRhs)
cpePair :: TopLevelFlag
-> RecFlag
-> Demand
-> Bool
-> CorePrepEnv
-> Id
-> CpeBody
-> UniqSM (Floats, CpeBody)
cpePair TopLevelFlag
top_lvl RecFlag
is_rec Demand
dmd Bool
is_unlifted CorePrepEnv
env Id
bndr CpeBody
rhs
= ASSERT(not (isJoinId bndr))
do { (Floats
floats1, CpeBody
rhs1) <- CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeRhsE CorePrepEnv
env CpeBody
rhs
; (Floats
floats2, CpeBody
rhs2) <- Floats -> CpeBody -> UniqSM (Floats, CpeBody)
float_from_rhs Floats
floats1 CpeBody
rhs1
; (Floats
floats3, CpeBody
rhs3)
<- if CpeBody -> Int
manifestArity CpeBody
rhs1 forall a. Ord a => a -> a -> Bool
<= Int
arity
then forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats2, Int -> CpeBody -> CpeBody
cpeEtaExpand Int
arity CpeBody
rhs2)
else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
(do { Id
v <- Type -> UniqSM Id
newVar (Id -> Type
idType Id
bndr)
; let float :: FloatingBind
float = Demand -> Bool -> Id -> CpeBody -> FloatingBind
mkFloat Demand
topDmd Bool
False Id
v CpeBody
rhs2
; forall (m :: * -> *) a. Monad m => a -> m a
return ( Floats -> FloatingBind -> Floats
addFloat Floats
floats2 FloatingBind
float
, Int -> CpeBody -> CpeBody
cpeEtaExpand Int
arity (forall b. Id -> Expr b
Var Id
v)) })
; let (Floats
floats4, CpeBody
rhs4) = Floats -> CpeBody -> (Floats, CpeBody)
wrapTicks Floats
floats3 CpeBody
rhs3
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats4, CpeBody
rhs4) }
where
arity :: Int
arity = Id -> Int
idArity Id
bndr
float_from_rhs :: Floats -> CpeBody -> UniqSM (Floats, CpeBody)
float_from_rhs Floats
floats CpeBody
rhs
| Floats -> Bool
isEmptyFloats Floats
floats = forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeBody
rhs)
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl = Floats -> CpeBody -> UniqSM (Floats, CpeBody)
float_top Floats
floats CpeBody
rhs
| Bool
otherwise = Floats -> CpeBody -> UniqSM (Floats, CpeBody)
float_nested Floats
floats CpeBody
rhs
float_nested :: Floats -> CpeBody -> UniqSM (Floats, CpeBody)
float_nested Floats
floats CpeBody
rhs
| RecFlag -> Demand -> Bool -> Floats -> CpeBody -> Bool
wantFloatNested RecFlag
is_rec Demand
dmd Bool
is_unlifted Floats
floats CpeBody
rhs
= forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeBody
rhs)
| Bool
otherwise = Floats -> CpeBody -> UniqSM (Floats, CpeBody)
dontFloat Floats
floats CpeBody
rhs
float_top :: Floats -> CpeBody -> UniqSM (Floats, CpeBody)
float_top Floats
floats CpeBody
rhs
| Floats -> Bool
allLazyTop Floats
floats
= forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeBody
rhs)
| Just (Floats, CpeBody)
floats <- Floats -> CpeBody -> Maybe (Floats, CpeBody)
canFloat Floats
floats CpeBody
rhs
= forall (m :: * -> *) a. Monad m => a -> m a
return (Floats, CpeBody)
floats
| Bool
otherwise
= Floats -> CpeBody -> UniqSM (Floats, CpeBody)
dontFloat Floats
floats CpeBody
rhs
dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)
dontFloat :: Floats -> CpeBody -> UniqSM (Floats, CpeBody)
dontFloat Floats
floats1 CpeBody
rhs
= do { (Floats
floats2, CpeBody
body) <- CpeBody -> UniqSM (Floats, CpeBody)
rhsToBody CpeBody
rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Floats -> CpeBody -> CpeBody
wrapBinds Floats
floats1 forall a b. (a -> b) -> a -> b
$
Floats -> CpeBody -> CpeBody
wrapBinds Floats
floats2 CpeBody
body) }
cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
-> UniqSM (JoinId, CpeRhs)
cpeJoinPair :: CorePrepEnv -> Id -> CpeBody -> UniqSM (Id, CpeBody)
cpeJoinPair CorePrepEnv
env Id
bndr CpeBody
rhs
= ASSERT(isJoinId bndr)
do { let Just Int
join_arity = Id -> Maybe Int
isJoinId_maybe Id
bndr
([Id]
bndrs, CpeBody
body) = forall b. Int -> Expr b -> ([b], Expr b)
collectNBinders Int
join_arity CpeBody
rhs
; (CorePrepEnv
env', [Id]
bndrs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
; CpeBody
body' <- CorePrepEnv -> CpeBody -> UniqSM CpeBody
cpeBodyNF CorePrepEnv
env' CpeBody
body
; let rhs' :: CpeBody
rhs' = [Id] -> CpeBody -> CpeBody
mkCoreLams [Id]
bndrs' CpeBody
body'
bndr' :: Id
bndr' = Id
bndr Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
evaldUnfolding
Id -> Int -> Id
`setIdArity` forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
bndrs
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id
bndr', CpeBody
rhs') }
cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeRhsE :: CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeRhsE CorePrepEnv
env (Type Type
ty)
= forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, forall b. Type -> Expr b
Type (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty))
cpeRhsE CorePrepEnv
env (Coercion Coercion
co)
= forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, forall b. Coercion -> Expr b
Coercion (CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co))
cpeRhsE CorePrepEnv
env expr :: CpeBody
expr@(Lit (LitNumber LitNumType
nt Integer
i))
= case CorePrepEnv -> LitNumType -> Integer -> Maybe CpeBody
cpe_convertNumLit CorePrepEnv
env LitNumType
nt Integer
i of
Maybe CpeBody
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeBody
expr)
Just CpeBody
e -> CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeRhsE CorePrepEnv
env CpeBody
e
cpeRhsE CorePrepEnv
_env expr :: CpeBody
expr@(Lit {}) = forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeBody
expr)
cpeRhsE CorePrepEnv
env expr :: CpeBody
expr@(Var {}) = CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeApp CorePrepEnv
env CpeBody
expr
cpeRhsE CorePrepEnv
env expr :: CpeBody
expr@(App {}) = CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeApp CorePrepEnv
env CpeBody
expr
cpeRhsE CorePrepEnv
env (Let CoreBind
bind CpeBody
body)
= do { (CorePrepEnv
env', Floats
bind_floats, Maybe CoreBind
maybe_bind') <- TopLevelFlag
-> CorePrepEnv
-> CoreBind
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
cpeBind TopLevelFlag
NotTopLevel CorePrepEnv
env CoreBind
bind
; (Floats
body_floats, CpeBody
body') <- CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeRhsE CorePrepEnv
env' CpeBody
body
; let expr' :: CpeBody
expr' = case Maybe CoreBind
maybe_bind' of Just CoreBind
bind' -> forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind' CpeBody
body'
Maybe CoreBind
Nothing -> CpeBody
body'
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
bind_floats Floats -> Floats -> Floats
`appendFloats` Floats
body_floats, CpeBody
expr') }
cpeRhsE CorePrepEnv
env (Tick CoreTickish
tickish CpeBody
expr)
| forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
tickish forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceNonLam Bool -> Bool -> Bool
&& CoreTickish
tickish forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
= do { (Floats
floats, CpeBody
body) <- CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeRhsE CorePrepEnv
env CpeBody
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (FloatingBind -> Floats
unitFloat (CoreTickish -> FloatingBind
FloatTick CoreTickish
tickish) Floats -> Floats -> Floats
`appendFloats` Floats
floats, CpeBody
body) }
| Bool
otherwise
= do { CpeBody
body <- CorePrepEnv -> CpeBody -> UniqSM CpeBody
cpeBodyNF CorePrepEnv
env CpeBody
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CoreTickish -> CpeBody -> CpeBody
mkTick CoreTickish
tickish' CpeBody
body) }
where
tickish' :: CoreTickish
tickish' | Breakpoint XBreakpoint 'TickishPassCore
ext Int
n [XTickishId 'TickishPassCore]
fvs <- CoreTickish
tickish
= forall (pass :: TickishPass).
XBreakpoint pass -> Int -> [XTickishId pass] -> GenTickish pass
Breakpoint XBreakpoint 'TickishPassCore
ext Int
n (forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => CpeBody -> Id
getIdFromTrivialExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. CorePrepEnv -> Id -> CpeBody
lookupCorePrepEnv CorePrepEnv
env) [XTickishId 'TickishPassCore]
fvs)
| Bool
otherwise
= CoreTickish
tickish
cpeRhsE CorePrepEnv
env (Cast CpeBody
expr Coercion
co)
= do { (Floats
floats, CpeBody
expr') <- CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeRhsE CorePrepEnv
env CpeBody
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, forall b. Expr b -> Coercion -> Expr b
Cast CpeBody
expr' (CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co)) }
cpeRhsE CorePrepEnv
env expr :: CpeBody
expr@(Lam {})
= do { let ([Id]
bndrs,CpeBody
body) = forall b. Expr b -> ([b], Expr b)
collectBinders CpeBody
expr
; (CorePrepEnv
env', [Id]
bndrs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
; CpeBody
body' <- CorePrepEnv -> CpeBody -> UniqSM CpeBody
cpeBodyNF CorePrepEnv
env' CpeBody
body
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bndrs' CpeBody
body') }
cpeRhsE CorePrepEnv
env (Case CpeBody
scrut Id
_ Type
ty [])
= do { (Floats
floats, CpeBody
scrut') <- CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeRhsE CorePrepEnv
env CpeBody
scrut
; let ty' :: Type
ty' = CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty
scrut_ty' :: Type
scrut_ty' = CpeBody -> Type
exprType CpeBody
scrut'
co' :: Coercion
co' = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkUnivCo UnivCoProvenance
prov Role
Representational Type
scrut_ty' Type
ty'
prov :: UnivCoProvenance
prov = Bool -> UnivCoProvenance
CorePrepProv Bool
False
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, forall b. Expr b -> Coercion -> Expr b
Cast CpeBody
scrut' Coercion
co') }
cpeRhsE CorePrepEnv
env (Case CpeBody
scrut Id
bndr Type
_ [Alt Id]
alts)
| CpeBody -> Bool
isUnsafeEqualityProof CpeBody
scrut
, Id -> Bool
isDeadBinder Id
bndr
, [Alt AltCon
_ [Id
co_var] CpeBody
rhs] <- [Alt Id]
alts
, let Pair Type
ty1 Type
ty2 = HasDebugCallStack => Id -> Pair Type
coVarTypes Id
co_var
the_co :: Coercion
the_co = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkUnivCo UnivCoProvenance
prov Role
Nominal (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty1) (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty2)
prov :: UnivCoProvenance
prov = Bool -> UnivCoProvenance
CorePrepProv Bool
True
env' :: CorePrepEnv
env' = CorePrepEnv -> Id -> Coercion -> CorePrepEnv
extendCoVarEnv CorePrepEnv
env Id
co_var Coercion
the_co
= CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeRhsE CorePrepEnv
env' CpeBody
rhs
cpeRhsE CorePrepEnv
env (Case CpeBody
scrut Id
bndr Type
ty [Alt Id]
alts)
= do { (Floats
floats, CpeBody
scrut') <- CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeBody CorePrepEnv
env CpeBody
scrut
; (CorePrepEnv
env', Id
bndr2) <- CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env Id
bndr
; let alts' :: [Alt Id]
alts'
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CatchBottoms (CorePrepEnv -> DynFlags
cpe_dynFlags CorePrepEnv
env)
, Bool -> Bool
not (forall b. [Alt b] -> Bool
altsAreExhaustive [Alt Id]
alts)
= forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
addDefault [Alt Id]
alts (forall a. a -> Maybe a
Just CpeBody
err)
| Bool
otherwise = [Alt Id]
alts
where err :: CpeBody
err = Id -> Type -> String -> CpeBody
mkRuntimeErrorApp Id
rUNTIME_ERROR_ID Type
ty
String
"Bottoming expression returned"
; [Alt Id]
alts'' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CorePrepEnv -> Alt Id -> UniqSM (Alt Id)
sat_alt CorePrepEnv
env') [Alt Id]
alts'
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeBody
scrut' Id
bndr2 Type
ty [Alt Id]
alts'') }
where
sat_alt :: CorePrepEnv -> Alt Id -> UniqSM (Alt Id)
sat_alt CorePrepEnv
env (Alt AltCon
con [Id]
bs CpeBody
rhs)
= do { (CorePrepEnv
env2, [Id]
bs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bs
; CpeBody
rhs' <- CorePrepEnv -> CpeBody -> UniqSM CpeBody
cpeBodyNF CorePrepEnv
env2 CpeBody
rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bs' CpeBody
rhs') }
cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
cpeBodyNF :: CorePrepEnv -> CpeBody -> UniqSM CpeBody
cpeBodyNF CorePrepEnv
env CpeBody
expr
= do { (Floats
floats, CpeBody
body) <- CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeBody CorePrepEnv
env CpeBody
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> CpeBody -> CpeBody
wrapBinds Floats
floats CpeBody
body) }
cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
cpeBody :: CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeBody CorePrepEnv
env CpeBody
expr
= do { (Floats
floats1, CpeBody
rhs) <- CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeRhsE CorePrepEnv
env CpeBody
expr
; (Floats
floats2, CpeBody
body) <- CpeBody -> UniqSM (Floats, CpeBody)
rhsToBody CpeBody
rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats1 Floats -> Floats -> Floats
`appendFloats` Floats
floats2, CpeBody
body) }
rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
rhsToBody :: CpeBody -> UniqSM (Floats, CpeBody)
rhsToBody (Tick CoreTickish
t CpeBody
expr)
| forall (pass :: TickishPass). GenTickish pass -> TickishScoping
tickishScoped CoreTickish
t forall a. Eq a => a -> a -> Bool
== TickishScoping
NoScope
= do { (Floats
floats, CpeBody
expr') <- CpeBody -> UniqSM (Floats, CpeBody)
rhsToBody CpeBody
expr
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CoreTickish -> CpeBody -> CpeBody
mkTick CoreTickish
t CpeBody
expr') }
rhsToBody (Cast CpeBody
e Coercion
co)
= do { (Floats
floats, CpeBody
e') <- CpeBody -> UniqSM (Floats, CpeBody)
rhsToBody CpeBody
e
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, forall b. Expr b -> Coercion -> Expr b
Cast CpeBody
e' Coercion
co) }
rhsToBody expr :: CpeBody
expr@(Lam {})
| Just CpeBody
no_lam_result <- [Id] -> CpeBody -> Maybe CpeBody
tryEtaReducePrep [Id]
bndrs CpeBody
body
= forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeBody
no_lam_result)
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isTyVar [Id]
bndrs
= forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeBody
expr)
| Bool
otherwise
= do { let rhs :: CpeBody
rhs = Int -> CpeBody -> CpeBody
cpeEtaExpand (CpeBody -> Int
exprArity CpeBody
expr) CpeBody
expr
; Id
fn <- Type -> UniqSM Id
newVar (CpeBody -> Type
exprType CpeBody
rhs)
; let float :: FloatingBind
float = CoreBind -> FloatingBind
FloatLet (forall b. b -> Expr b -> Bind b
NonRec Id
fn CpeBody
rhs)
; forall (m :: * -> *) a. Monad m => a -> m a
return (FloatingBind -> Floats
unitFloat FloatingBind
float, forall b. Id -> Expr b
Var Id
fn) }
where
([Id]
bndrs,CpeBody
body) = forall b. Expr b -> ([b], Expr b)
collectBinders CpeBody
expr
rhsToBody CpeBody
expr = forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeBody
expr)
data ArgInfo = CpeApp CoreArg
| CpeCast Coercion
| CpeTick CoreTickish
instance Outputable ArgInfo where
ppr :: ArgInfo -> SDoc
ppr (CpeApp CpeBody
arg) = String -> SDoc
text String
"app" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CpeBody
arg
ppr (CpeCast Coercion
co) = String -> SDoc
text String
"cast" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Coercion
co
ppr (CpeTick CoreTickish
tick) = String -> SDoc
text String
"tick" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CoreTickish
tick
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeApp :: CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeApp CorePrepEnv
top_env CpeBody
expr
= do { let (CpeBody
terminal, [ArgInfo]
args, Int
depth) = CpeBody -> (CpeBody, [ArgInfo], Int)
collect_args CpeBody
expr
; CorePrepEnv
-> CpeBody -> [ArgInfo] -> Int -> UniqSM (Floats, CpeBody)
cpe_app CorePrepEnv
top_env CpeBody
terminal [ArgInfo]
args Int
depth
}
where
collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)
collect_args :: CpeBody -> (CpeBody, [ArgInfo], Int)
collect_args CpeBody
e = forall {c}.
Num c =>
CpeBody -> [ArgInfo] -> c -> (CpeBody, [ArgInfo], c)
go CpeBody
e [] Int
0
where
go :: CpeBody -> [ArgInfo] -> c -> (CpeBody, [ArgInfo], c)
go (App CpeBody
fun CpeBody
arg) [ArgInfo]
as !c
depth
= CpeBody -> [ArgInfo] -> c -> (CpeBody, [ArgInfo], c)
go CpeBody
fun (CpeBody -> ArgInfo
CpeApp CpeBody
arg forall a. a -> [a] -> [a]
: [ArgInfo]
as)
(if forall b. Expr b -> Bool
isTyCoArg CpeBody
arg then c
depth else c
depth forall a. Num a => a -> a -> a
+ c
1)
go (Cast CpeBody
fun Coercion
co) [ArgInfo]
as c
depth
= CpeBody -> [ArgInfo] -> c -> (CpeBody, [ArgInfo], c)
go CpeBody
fun (Coercion -> ArgInfo
CpeCast Coercion
co forall a. a -> [a] -> [a]
: [ArgInfo]
as) c
depth
go (Tick CoreTickish
tickish CpeBody
fun) [ArgInfo]
as c
depth
| forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
tickish forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceNonLam
Bool -> Bool -> Bool
&& CoreTickish
tickish forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
= CpeBody -> [ArgInfo] -> c -> (CpeBody, [ArgInfo], c)
go CpeBody
fun (CoreTickish -> ArgInfo
CpeTick CoreTickish
tickish forall a. a -> [a] -> [a]
: [ArgInfo]
as) c
depth
go CpeBody
terminal [ArgInfo]
as c
depth = (CpeBody
terminal, [ArgInfo]
as, c
depth)
cpe_app :: CorePrepEnv
-> CoreExpr
-> [ArgInfo]
-> Int
-> UniqSM (Floats, CpeRhs)
cpe_app :: CorePrepEnv
-> CpeBody -> [ArgInfo] -> Int -> UniqSM (Floats, CpeBody)
cpe_app CorePrepEnv
env (Var Id
f) (CpeApp Type{} : CpeApp CpeBody
arg : [ArgInfo]
args) Int
depth
| Id
f forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
lazyIdKey
Bool -> Bool -> Bool
|| Id
f forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
noinlineIdKey
= let (CpeBody
terminal, [ArgInfo]
args', Int
depth') = CpeBody -> (CpeBody, [ArgInfo], Int)
collect_args CpeBody
arg
in CorePrepEnv
-> CpeBody -> [ArgInfo] -> Int -> UniqSM (Floats, CpeBody)
cpe_app CorePrepEnv
env CpeBody
terminal ([ArgInfo]
args' forall a. [a] -> [a] -> [a]
++ [ArgInfo]
args) (Int
depth forall a. Num a => a -> a -> a
+ Int
depth' forall a. Num a => a -> a -> a
- Int
1)
cpe_app CorePrepEnv
env (Var Id
f) (CpeApp _runtimeRep :: CpeBody
_runtimeRep@Type{} : CpeApp _type :: CpeBody
_type@Type{} : CpeApp CpeBody
arg : [ArgInfo]
rest) Int
n
| Id
f forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
runRWKey
, Int
n forall a. Ord a => a -> a -> Bool
>= Int
1
= case CpeBody
arg of
Lam Id
s CpeBody
body -> CorePrepEnv
-> CpeBody -> [ArgInfo] -> Int -> UniqSM (Floats, CpeBody)
cpe_app (CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env Id
s Id
realWorldPrimId) CpeBody
body [ArgInfo]
rest (Int
nforall a. Num a => a -> a -> a
-Int
2)
CpeBody
_ -> CorePrepEnv
-> CpeBody -> [ArgInfo] -> Int -> UniqSM (Floats, CpeBody)
cpe_app CorePrepEnv
env CpeBody
arg (CpeBody -> ArgInfo
CpeApp (forall b. Id -> Expr b
Var Id
realWorldPrimId) forall a. a -> [a] -> [a]
: [ArgInfo]
rest) (Int
nforall a. Num a => a -> a -> a
-Int
1)
cpe_app CorePrepEnv
env (Var Id
v) [ArgInfo]
args Int
depth
= do { Id
v1 <- Id -> UniqSM Id
fiddleCCall Id
v
; let e2 :: CpeBody
e2 = CorePrepEnv -> Id -> CpeBody
lookupCorePrepEnv CorePrepEnv
env Id
v1
hd :: Maybe Id
hd = CpeBody -> Maybe Id
getIdFromTrivialExpr_maybe CpeBody
e2
; (CpeBody
app, Floats
floats) <- CorePrepEnv
-> [ArgInfo]
-> CpeBody
-> Floats
-> [Demand]
-> UniqSM (CpeBody, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
args CpeBody
e2 Floats
emptyFloats [Demand]
stricts
; forall {a}. Maybe Id -> CpeBody -> a -> Int -> UniqSM (a, CpeBody)
mb_saturate Maybe Id
hd CpeBody
app Floats
floats Int
depth }
where
stricts :: [Demand]
stricts = case Id -> StrictSig
idStrictness Id
v of
StrictSig (DmdType DmdEnv
_ [Demand]
demands Divergence
_)
| forall a. [a] -> Int -> Ordering
listLengthCmp [Demand]
demands Int
depth forall a. Eq a => a -> a -> Bool
/= Ordering
GT -> [Demand]
demands
| Bool
otherwise -> []
cpe_app CorePrepEnv
env CpeBody
fun [] Int
_ = CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeRhsE CorePrepEnv
env CpeBody
fun
cpe_app CorePrepEnv
env CpeBody
fun [ArgInfo]
args Int
depth
= do { (Floats
fun_floats, CpeBody
fun') <- CorePrepEnv -> Demand -> CpeBody -> UniqSM (Floats, CpeBody)
cpeArg CorePrepEnv
env Demand
evalDmd CpeBody
fun
; (CpeBody
app, Floats
floats) <- CorePrepEnv
-> [ArgInfo]
-> CpeBody
-> Floats
-> [Demand]
-> UniqSM (CpeBody, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
args CpeBody
fun' Floats
fun_floats []
; forall {a}. Maybe Id -> CpeBody -> a -> Int -> UniqSM (a, CpeBody)
mb_saturate forall a. Maybe a
Nothing CpeBody
app Floats
floats Int
depth }
mb_saturate :: Maybe Id -> CpeBody -> a -> Int -> UniqSM (a, CpeBody)
mb_saturate Maybe Id
head CpeBody
app a
floats Int
depth =
case Maybe Id
head of
Just Id
fn_id -> do { CpeBody
sat_app <- Id -> CpeBody -> Int -> UniqSM CpeBody
maybeSaturate Id
fn_id CpeBody
app Int
depth
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
floats, CpeBody
sat_app) }
Maybe Id
_other -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
floats, CpeBody
app)
rebuild_app
:: CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> UniqSM (CpeApp, Floats)
rebuild_app :: CorePrepEnv
-> [ArgInfo]
-> CpeBody
-> Floats
-> [Demand]
-> UniqSM (CpeBody, Floats)
rebuild_app CorePrepEnv
_ [] CpeBody
app Floats
floats [Demand]
ss
= ASSERT(null ss)
forall (m :: * -> *) a. Monad m => a -> m a
return (CpeBody
app, Floats
floats)
rebuild_app CorePrepEnv
env (ArgInfo
a : [ArgInfo]
as) CpeBody
fun' Floats
floats [Demand]
ss = case ArgInfo
a of
CpeApp (Type Type
arg_ty)
-> CorePrepEnv
-> [ArgInfo]
-> CpeBody
-> Floats
-> [Demand]
-> UniqSM (CpeBody, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
as (forall b. Expr b -> Expr b -> Expr b
App CpeBody
fun' (forall b. Type -> Expr b
Type Type
arg_ty')) Floats
floats [Demand]
ss
where
arg_ty' :: Type
arg_ty' = CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
arg_ty
CpeApp (Coercion Coercion
co)
-> CorePrepEnv
-> [ArgInfo]
-> CpeBody
-> Floats
-> [Demand]
-> UniqSM (CpeBody, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
as (forall b. Expr b -> Expr b -> Expr b
App CpeBody
fun' (forall b. Coercion -> Expr b
Coercion Coercion
co')) Floats
floats [Demand]
ss
where
co' :: Coercion
co' = CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co
CpeApp CpeBody
arg -> do
let (Demand
ss1, [Demand]
ss_rest)
= case ([Demand]
ss, CpeBody -> Bool
isLazyExpr CpeBody
arg) of
(Demand
_ : [Demand]
ss_rest, Bool
True) -> (Demand
topDmd, [Demand]
ss_rest)
(Demand
ss1 : [Demand]
ss_rest, Bool
False) -> (Demand
ss1, [Demand]
ss_rest)
([], Bool
_) -> (Demand
topDmd, [])
(Floats
fs, CpeBody
arg') <- CorePrepEnv -> Demand -> CpeBody -> UniqSM (Floats, CpeBody)
cpeArg CorePrepEnv
top_env Demand
ss1 CpeBody
arg
CorePrepEnv
-> [ArgInfo]
-> CpeBody
-> Floats
-> [Demand]
-> UniqSM (CpeBody, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
as (forall b. Expr b -> Expr b -> Expr b
App CpeBody
fun' CpeBody
arg') (Floats
fs Floats -> Floats -> Floats
`appendFloats` Floats
floats) [Demand]
ss_rest
CpeCast Coercion
co
-> CorePrepEnv
-> [ArgInfo]
-> CpeBody
-> Floats
-> [Demand]
-> UniqSM (CpeBody, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
as (forall b. Expr b -> Coercion -> Expr b
Cast CpeBody
fun' Coercion
co') Floats
floats [Demand]
ss
where
co' :: Coercion
co' = CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co
CpeTick CoreTickish
tickish
-> CorePrepEnv
-> [ArgInfo]
-> CpeBody
-> Floats
-> [Demand]
-> UniqSM (CpeBody, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
as CpeBody
fun' (Floats -> FloatingBind -> Floats
addFloat Floats
floats (CoreTickish -> FloatingBind
FloatTick CoreTickish
tickish)) [Demand]
ss
isLazyExpr :: CoreExpr -> Bool
isLazyExpr :: CpeBody -> Bool
isLazyExpr (Cast CpeBody
e Coercion
_) = CpeBody -> Bool
isLazyExpr CpeBody
e
isLazyExpr (Tick CoreTickish
_ CpeBody
e) = CpeBody -> Bool
isLazyExpr CpeBody
e
isLazyExpr (Var Id
f `App` CpeBody
_ `App` CpeBody
_) = Id
f forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
lazyIdKey
isLazyExpr CpeBody
_ = Bool
False
okCpeArg :: CoreExpr -> Bool
okCpeArg :: CpeBody -> Bool
okCpeArg (Lit Literal
_) = Bool
False
okCpeArg CpeBody
expr = Bool -> Bool
not (CpeBody -> Bool
exprIsTrivial CpeBody
expr)
cpeArg :: CorePrepEnv -> Demand
-> CoreArg -> UniqSM (Floats, CpeArg)
cpeArg :: CorePrepEnv -> Demand -> CpeBody -> UniqSM (Floats, CpeBody)
cpeArg CorePrepEnv
env Demand
dmd CpeBody
arg
= do { (Floats
floats1, CpeBody
arg1) <- CorePrepEnv -> CpeBody -> UniqSM (Floats, CpeBody)
cpeRhsE CorePrepEnv
env CpeBody
arg
; let arg_ty :: Type
arg_ty = CpeBody -> Type
exprType CpeBody
arg1
is_unlifted :: Bool
is_unlifted = HasDebugCallStack => Type -> Bool
isUnliftedType Type
arg_ty
want_float :: Floats -> CpeBody -> Bool
want_float = RecFlag -> Demand -> Bool -> Floats -> CpeBody -> Bool
wantFloatNested RecFlag
NonRecursive Demand
dmd Bool
is_unlifted
; (Floats
floats2, CpeBody
arg2) <- if Floats -> CpeBody -> Bool
want_float Floats
floats1 CpeBody
arg1
then forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats1, CpeBody
arg1)
else Floats -> CpeBody -> UniqSM (Floats, CpeBody)
dontFloat Floats
floats1 CpeBody
arg1
; if CpeBody -> Bool
okCpeArg CpeBody
arg2
then do { Id
v <- Type -> UniqSM Id
newVar Type
arg_ty
; let arg3 :: CpeBody
arg3 = Int -> CpeBody -> CpeBody
cpeEtaExpand (CpeBody -> Int
exprArity CpeBody
arg2) CpeBody
arg2
arg_float :: FloatingBind
arg_float = Demand -> Bool -> Id -> CpeBody -> FloatingBind
mkFloat Demand
dmd Bool
is_unlifted Id
v CpeBody
arg3
; forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> FloatingBind -> Floats
addFloat Floats
floats2 FloatingBind
arg_float, forall b. Id -> Expr b
varToCoreExpr Id
v) }
else forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats2, CpeBody
arg2)
}
maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
maybeSaturate :: Id -> CpeBody -> Int -> UniqSM CpeBody
maybeSaturate Id
fn CpeBody
expr Int
n_args
| Id -> Bool
hasNoBinding Id
fn
= forall (m :: * -> *) a. Monad m => a -> m a
return CpeBody
sat_expr
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return CpeBody
expr
where
fn_arity :: Int
fn_arity = Id -> Int
idArity Id
fn
excess_arity :: Int
excess_arity = Int
fn_arity forall a. Num a => a -> a -> a
- Int
n_args
sat_expr :: CpeBody
sat_expr = Int -> CpeBody -> CpeBody
cpeEtaExpand Int
excess_arity CpeBody
expr
cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
cpeEtaExpand :: Int -> CpeBody -> CpeBody
cpeEtaExpand Int
arity CpeBody
expr
| Int
arity forall a. Eq a => a -> a -> Bool
== Int
0 = CpeBody
expr
| Bool
otherwise = Int -> CpeBody -> CpeBody
etaExpand Int
arity CpeBody
expr
tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
tryEtaReducePrep :: [Id] -> CpeBody -> Maybe CpeBody
tryEtaReducePrep [Id]
bndrs expr :: CpeBody
expr@(App CpeBody
_ CpeBody
_)
| forall b. Expr b -> Bool
ok_to_eta_reduce CpeBody
f
, Int
n_remaining forall a. Ord a => a -> a -> Bool
>= Int
0
, forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {b}. Id -> Expr b -> Bool
ok [Id]
bndrs [CpeBody]
last_args)
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> VarSet -> Bool
`elemVarSet` VarSet
fvs_remaining) [Id]
bndrs)
, CpeBody -> Bool
exprIsHNF CpeBody
remaining_expr
= forall a. a -> Maybe a
Just CpeBody
remaining_expr
where
(CpeBody
f, [CpeBody]
args) = forall b. Expr b -> (Expr b, [Expr b])
collectArgs CpeBody
expr
remaining_expr :: CpeBody
remaining_expr = forall b. Expr b -> [Expr b] -> Expr b
mkApps CpeBody
f [CpeBody]
remaining_args
fvs_remaining :: VarSet
fvs_remaining = CpeBody -> VarSet
exprFreeVars CpeBody
remaining_expr
([CpeBody]
remaining_args, [CpeBody]
last_args) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_remaining [CpeBody]
args
n_remaining :: Int
n_remaining = forall (t :: * -> *) a. Foldable t => t a -> Int
length [CpeBody]
args forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
bndrs
ok :: Id -> Expr b -> Bool
ok Id
bndr (Var Id
arg) = Id
bndr forall a. Eq a => a -> a -> Bool
== Id
arg
ok Id
_ Expr b
_ = Bool
False
ok_to_eta_reduce :: Expr b -> Bool
ok_to_eta_reduce (Var Id
f) = Bool -> Bool
not (Id -> Bool
hasNoBinding Id
f) Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isLinearType (Id -> Type
idType Id
f))
ok_to_eta_reduce Expr b
_ = Bool
False
tryEtaReducePrep [Id]
bndrs (Tick CoreTickish
tickish CpeBody
e)
| forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
tickish
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CoreTickish -> CpeBody -> CpeBody
mkTick CoreTickish
tickish) forall a b. (a -> b) -> a -> b
$ [Id] -> CpeBody -> Maybe CpeBody
tryEtaReducePrep [Id]
bndrs CpeBody
e
tryEtaReducePrep [Id]
_ CpeBody
_ = forall a. Maybe a
Nothing
data FloatingBind
= FloatLet CoreBind
| FloatCase
CpeBody
Id
AltCon [Var]
Bool
| FloatTick CoreTickish
data Floats = Floats OkToSpec (OrdList FloatingBind)
instance Outputable FloatingBind where
ppr :: FloatingBind -> SDoc
ppr (FloatLet CoreBind
b) = forall a. Outputable a => a -> SDoc
ppr CoreBind
b
ppr (FloatCase CpeBody
r Id
b AltCon
k [Id]
bs Bool
ok) = String -> SDoc
text String
"case" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (forall a. Outputable a => a -> SDoc
ppr Bool
ok) SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CpeBody
r
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"of"SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Id
b SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"@"
SDoc -> SDoc -> SDoc
<> case [Id]
bs of
[] -> forall a. Outputable a => a -> SDoc
ppr AltCon
k
[Id]
_ -> SDoc -> SDoc
parens (forall a. Outputable a => a -> SDoc
ppr AltCon
k SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Id]
bs)
ppr (FloatTick CoreTickish
t) = forall a. Outputable a => a -> SDoc
ppr CoreTickish
t
instance Outputable Floats where
ppr :: Floats -> SDoc
ppr (Floats OkToSpec
flag OrdList FloatingBind
fs) = String -> SDoc
text String
"Floats" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (forall a. Outputable a => a -> SDoc
ppr OkToSpec
flag) SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr (forall a. OrdList a -> [a]
fromOL OrdList FloatingBind
fs)))
instance Outputable OkToSpec where
ppr :: OkToSpec -> SDoc
ppr OkToSpec
OkToSpec = String -> SDoc
text String
"OkToSpec"
ppr OkToSpec
IfUnboxedOk = String -> SDoc
text String
"IfUnboxedOk"
ppr OkToSpec
NotOkToSpec = String -> SDoc
text String
"NotOkToSpec"
data OkToSpec
= OkToSpec
| IfUnboxedOk
| NotOkToSpec
mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
mkFloat :: Demand -> Bool -> Id -> CpeBody -> FloatingBind
mkFloat Demand
dmd Bool
is_unlifted Id
bndr CpeBody
rhs
| Bool
is_strict Bool -> Bool -> Bool
|| Bool
ok_for_spec
, Bool -> Bool
not Bool
is_hnf = CpeBody -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase CpeBody
rhs Id
bndr AltCon
DEFAULT [] Bool
ok_for_spec
| Bool
is_unlifted = CpeBody -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase CpeBody
rhs Id
bndr AltCon
DEFAULT [] Bool
True
| Bool
is_hnf = CoreBind -> FloatingBind
FloatLet (forall b. b -> Expr b -> Bind b
NonRec Id
bndr CpeBody
rhs)
| Bool
otherwise = CoreBind -> FloatingBind
FloatLet (forall b. b -> Expr b -> Bind b
NonRec (Id -> Demand -> Id
setIdDemandInfo Id
bndr Demand
dmd) CpeBody
rhs)
where
is_hnf :: Bool
is_hnf = CpeBody -> Bool
exprIsHNF CpeBody
rhs
is_strict :: Bool
is_strict = Demand -> Bool
isStrUsedDmd Demand
dmd
ok_for_spec :: Bool
ok_for_spec = CpeBody -> Bool
exprOkForSpeculation CpeBody
rhs
emptyFloats :: Floats
emptyFloats :: Floats
emptyFloats = OkToSpec -> OrdList FloatingBind -> Floats
Floats OkToSpec
OkToSpec forall a. OrdList a
nilOL
isEmptyFloats :: Floats -> Bool
isEmptyFloats :: Floats -> Bool
isEmptyFloats (Floats OkToSpec
_ OrdList FloatingBind
bs) = forall a. OrdList a -> Bool
isNilOL OrdList FloatingBind
bs
wrapBinds :: Floats -> CpeBody -> CpeBody
wrapBinds :: Floats -> CpeBody -> CpeBody
wrapBinds (Floats OkToSpec
_ OrdList FloatingBind
binds) CpeBody
body
= forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> CpeBody -> CpeBody
mk_bind CpeBody
body OrdList FloatingBind
binds
where
mk_bind :: FloatingBind -> CpeBody -> CpeBody
mk_bind (FloatCase CpeBody
rhs Id
bndr AltCon
con [Id]
bs Bool
_) CpeBody
body = forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeBody
rhs Id
bndr (CpeBody -> Type
exprType CpeBody
body) [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bs CpeBody
body]
mk_bind (FloatLet CoreBind
bind) CpeBody
body = forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind CpeBody
body
mk_bind (FloatTick CoreTickish
tickish) CpeBody
body = CoreTickish -> CpeBody -> CpeBody
mkTick CoreTickish
tickish CpeBody
body
addFloat :: Floats -> FloatingBind -> Floats
addFloat :: Floats -> FloatingBind -> Floats
addFloat (Floats OkToSpec
ok_to_spec OrdList FloatingBind
floats) FloatingBind
new_float
= OkToSpec -> OrdList FloatingBind -> Floats
Floats (OkToSpec -> OkToSpec -> OkToSpec
combine OkToSpec
ok_to_spec (FloatingBind -> OkToSpec
check FloatingBind
new_float)) (OrdList FloatingBind
floats forall a. OrdList a -> a -> OrdList a
`snocOL` FloatingBind
new_float)
where
check :: FloatingBind -> OkToSpec
check (FloatLet {}) = OkToSpec
OkToSpec
check (FloatCase CpeBody
_ Id
_ AltCon
_ [Id]
_ Bool
ok_for_spec)
| Bool
ok_for_spec = OkToSpec
IfUnboxedOk
| Bool
otherwise = OkToSpec
NotOkToSpec
check FloatTick{} = OkToSpec
OkToSpec
unitFloat :: FloatingBind -> Floats
unitFloat :: FloatingBind -> Floats
unitFloat = Floats -> FloatingBind -> Floats
addFloat Floats
emptyFloats
appendFloats :: Floats -> Floats -> Floats
appendFloats :: Floats -> Floats -> Floats
appendFloats (Floats OkToSpec
spec1 OrdList FloatingBind
floats1) (Floats OkToSpec
spec2 OrdList FloatingBind
floats2)
= OkToSpec -> OrdList FloatingBind -> Floats
Floats (OkToSpec -> OkToSpec -> OkToSpec
combine OkToSpec
spec1 OkToSpec
spec2) (OrdList FloatingBind
floats1 forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList FloatingBind
floats2)
concatFloats :: [Floats] -> OrdList FloatingBind
concatFloats :: [Floats] -> OrdList FloatingBind
concatFloats = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Floats OkToSpec
_ OrdList FloatingBind
bs1) OrdList FloatingBind
bs2 -> forall a. OrdList a -> OrdList a -> OrdList a
appOL OrdList FloatingBind
bs1 OrdList FloatingBind
bs2) forall a. OrdList a
nilOL
combine :: OkToSpec -> OkToSpec -> OkToSpec
combine :: OkToSpec -> OkToSpec -> OkToSpec
combine OkToSpec
NotOkToSpec OkToSpec
_ = OkToSpec
NotOkToSpec
combine OkToSpec
_ OkToSpec
NotOkToSpec = OkToSpec
NotOkToSpec
combine OkToSpec
IfUnboxedOk OkToSpec
_ = OkToSpec
IfUnboxedOk
combine OkToSpec
_ OkToSpec
IfUnboxedOk = OkToSpec
IfUnboxedOk
combine OkToSpec
_ OkToSpec
_ = OkToSpec
OkToSpec
deFloatTop :: Floats -> [CoreBind]
deFloatTop :: Floats -> CoreProgram
deFloatTop (Floats OkToSpec
_ OrdList FloatingBind
floats)
= forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> CoreProgram -> CoreProgram
get [] OrdList FloatingBind
floats
where
get :: FloatingBind -> CoreProgram -> CoreProgram
get (FloatLet CoreBind
b) CoreProgram
bs = CoreBind -> CoreBind
get_bind CoreBind
b forall a. a -> [a] -> [a]
: CoreProgram
bs
get (FloatCase CpeBody
body Id
var AltCon
_ [Id]
_ Bool
_) CoreProgram
bs = CoreBind -> CoreBind
get_bind (forall b. b -> Expr b -> Bind b
NonRec Id
var CpeBody
body) forall a. a -> [a] -> [a]
: CoreProgram
bs
get FloatingBind
b CoreProgram
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"corePrepPgm" (forall a. Outputable a => a -> SDoc
ppr FloatingBind
b)
get_bind :: CoreBind -> CoreBind
get_bind (NonRec Id
x CpeBody
e) = forall b. b -> Expr b -> Bind b
NonRec Id
x (CpeBody -> CpeBody
occurAnalyseExpr CpeBody
e)
get_bind (Rec [(Id, CpeBody)]
xes) = forall b. [(b, Expr b)] -> Bind b
Rec [(Id
x, CpeBody -> CpeBody
occurAnalyseExpr CpeBody
e) | (Id
x, CpeBody
e) <- [(Id, CpeBody)]
xes]
canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
canFloat :: Floats -> CpeBody -> Maybe (Floats, CpeBody)
canFloat (Floats OkToSpec
ok_to_spec OrdList FloatingBind
fs) CpeBody
rhs
| OkToSpec
OkToSpec <- OkToSpec
ok_to_spec
, Just OrdList FloatingBind
fs' <- OrdList FloatingBind
-> [FloatingBind] -> Maybe (OrdList FloatingBind)
go forall a. OrdList a
nilOL (forall a. OrdList a -> [a]
fromOL OrdList FloatingBind
fs)
= forall a. a -> Maybe a
Just (OkToSpec -> OrdList FloatingBind -> Floats
Floats OkToSpec
OkToSpec OrdList FloatingBind
fs', CpeBody
rhs)
| Bool
otherwise
= forall a. Maybe a
Nothing
where
go :: OrdList FloatingBind -> [FloatingBind]
-> Maybe (OrdList FloatingBind)
go :: OrdList FloatingBind
-> [FloatingBind] -> Maybe (OrdList FloatingBind)
go (OrdList FloatingBind
fbs_out) [] = forall a. a -> Maybe a
Just OrdList FloatingBind
fbs_out
go OrdList FloatingBind
fbs_out (fb :: FloatingBind
fb@(FloatLet CoreBind
_) : [FloatingBind]
fbs_in)
= OrdList FloatingBind
-> [FloatingBind] -> Maybe (OrdList FloatingBind)
go (OrdList FloatingBind
fbs_out forall a. OrdList a -> a -> OrdList a
`snocOL` FloatingBind
fb) [FloatingBind]
fbs_in
go OrdList FloatingBind
fbs_out (ft :: FloatingBind
ft@FloatTick{} : [FloatingBind]
fbs_in)
= OrdList FloatingBind
-> [FloatingBind] -> Maybe (OrdList FloatingBind)
go (OrdList FloatingBind
fbs_out forall a. OrdList a -> a -> OrdList a
`snocOL` FloatingBind
ft) [FloatingBind]
fbs_in
go OrdList FloatingBind
_ (FloatCase{} : [FloatingBind]
_) = forall a. Maybe a
Nothing
wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeBody -> Bool
wantFloatNested RecFlag
is_rec Demand
dmd Bool
is_unlifted Floats
floats CpeBody
rhs
= Floats -> Bool
isEmptyFloats Floats
floats
Bool -> Bool -> Bool
|| Demand -> Bool
isStrUsedDmd Demand
dmd
Bool -> Bool -> Bool
|| Bool
is_unlifted
Bool -> Bool -> Bool
|| (RecFlag -> Floats -> Bool
allLazyNested RecFlag
is_rec Floats
floats Bool -> Bool -> Bool
&& CpeBody -> Bool
exprIsHNF CpeBody
rhs)
allLazyTop :: Floats -> Bool
allLazyTop :: Floats -> Bool
allLazyTop (Floats OkToSpec
OkToSpec OrdList FloatingBind
_) = Bool
True
allLazyTop Floats
_ = Bool
False
allLazyNested :: RecFlag -> Floats -> Bool
allLazyNested :: RecFlag -> Floats -> Bool
allLazyNested RecFlag
_ (Floats OkToSpec
OkToSpec OrdList FloatingBind
_) = Bool
True
allLazyNested RecFlag
_ (Floats OkToSpec
NotOkToSpec OrdList FloatingBind
_) = Bool
False
allLazyNested RecFlag
is_rec (Floats OkToSpec
IfUnboxedOk OrdList FloatingBind
_) = RecFlag -> Bool
isNonRec RecFlag
is_rec
data CorePrepEnv
= CPE { CorePrepEnv -> DynFlags
cpe_dynFlags :: DynFlags
, CorePrepEnv -> IdEnv CpeBody
cpe_env :: IdEnv CoreExpr
, CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env :: Maybe CpeTyCoEnv
, CorePrepEnv -> LitNumType -> Integer -> Maybe CpeBody
cpe_convertNumLit :: LitNumType -> Integer -> Maybe CoreExpr
}
mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv HscEnv
hsc_env = do
LitNumType -> Integer -> Maybe CpeBody
convertNumLit <- HscEnv -> IO (LitNumType -> Integer -> Maybe CpeBody)
mkConvertNumLiteral HscEnv
hsc_env
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CPE
{ cpe_dynFlags :: DynFlags
cpe_dynFlags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
, cpe_env :: IdEnv CpeBody
cpe_env = forall a. VarEnv a
emptyVarEnv
, cpe_tyco_env :: Maybe CpeTyCoEnv
cpe_tyco_env = forall a. Maybe a
Nothing
, cpe_convertNumLit :: LitNumType -> Integer -> Maybe CpeBody
cpe_convertNumLit = LitNumType -> Integer -> Maybe CpeBody
convertNumLit
}
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
cpe Id
id Id
id'
= CorePrepEnv
cpe { cpe_env :: IdEnv CpeBody
cpe_env = forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (CorePrepEnv -> IdEnv CpeBody
cpe_env CorePrepEnv
cpe) Id
id (forall b. Id -> Expr b
Var Id
id') }
extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CpeBody -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
cpe Id
id CpeBody
expr
= CorePrepEnv
cpe { cpe_env :: IdEnv CpeBody
cpe_env = forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (CorePrepEnv -> IdEnv CpeBody
cpe_env CorePrepEnv
cpe) Id
id CpeBody
expr }
extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
extendCorePrepEnvList :: CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
extendCorePrepEnvList CorePrepEnv
cpe [(Id, Id)]
prs
= CorePrepEnv
cpe { cpe_env :: IdEnv CpeBody
cpe_env = forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList (CorePrepEnv -> IdEnv CpeBody
cpe_env CorePrepEnv
cpe)
(forall a b. (a -> b) -> [a] -> [b]
map (\(Id
id, Id
id') -> (Id
id, forall b. Id -> Expr b
Var Id
id')) [(Id, Id)]
prs) }
lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
lookupCorePrepEnv :: CorePrepEnv -> Id -> CpeBody
lookupCorePrepEnv CorePrepEnv
cpe Id
id
= case forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (CorePrepEnv -> IdEnv CpeBody
cpe_env CorePrepEnv
cpe) Id
id of
Maybe CpeBody
Nothing -> forall b. Id -> Expr b
Var Id
id
Just CpeBody
exp -> CpeBody
exp
data CpeTyCoEnv = TCE TvSubstEnv CvSubstEnv
emptyTCE :: CpeTyCoEnv
emptyTCE :: CpeTyCoEnv
emptyTCE = TvSubstEnv -> CvSubstEnv -> CpeTyCoEnv
TCE TvSubstEnv
emptyTvSubstEnv CvSubstEnv
emptyCvSubstEnv
extend_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -> CpeTyCoEnv
extend_tce_cv :: CpeTyCoEnv -> Id -> Coercion -> CpeTyCoEnv
extend_tce_cv (TCE TvSubstEnv
tv_env CvSubstEnv
cv_env) Id
cv Coercion
co
= TvSubstEnv -> CvSubstEnv -> CpeTyCoEnv
TCE TvSubstEnv
tv_env (forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv CvSubstEnv
cv_env Id
cv Coercion
co)
extend_tce_tv :: CpeTyCoEnv -> TyVar -> Type -> CpeTyCoEnv
extend_tce_tv :: CpeTyCoEnv -> Id -> Type -> CpeTyCoEnv
extend_tce_tv (TCE TvSubstEnv
tv_env CvSubstEnv
cv_env) Id
tv Type
ty
= TvSubstEnv -> CvSubstEnv -> CpeTyCoEnv
TCE (forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv TvSubstEnv
tv_env Id
tv Type
ty) CvSubstEnv
cv_env
lookup_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion
lookup_tce_cv :: CpeTyCoEnv -> Id -> Coercion
lookup_tce_cv (TCE TvSubstEnv
_ CvSubstEnv
cv_env) Id
cv
= case forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv CvSubstEnv
cv_env Id
cv of
Just Coercion
co -> Coercion
co
Maybe Coercion
Nothing -> Id -> Coercion
mkCoVarCo Id
cv
lookup_tce_tv :: CpeTyCoEnv -> TyVar -> Type
lookup_tce_tv :: CpeTyCoEnv -> Id -> Type
lookup_tce_tv (TCE TvSubstEnv
tv_env CvSubstEnv
_) Id
tv
= case forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv TvSubstEnv
tv_env Id
tv of
Just Type
ty -> Type
ty
Maybe Type
Nothing -> Id -> Type
mkTyVarTy Id
tv
extendCoVarEnv :: CorePrepEnv -> CoVar -> Coercion -> CorePrepEnv
extendCoVarEnv :: CorePrepEnv -> Id -> Coercion -> CorePrepEnv
extendCoVarEnv cpe :: CorePrepEnv
cpe@(CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_tce }) Id
cv Coercion
co
= CorePrepEnv
cpe { cpe_tyco_env :: Maybe CpeTyCoEnv
cpe_tyco_env = forall a. a -> Maybe a
Just (CpeTyCoEnv -> Id -> Coercion -> CpeTyCoEnv
extend_tce_cv CpeTyCoEnv
tce Id
cv Coercion
co) }
where
tce :: CpeTyCoEnv
tce = Maybe CpeTyCoEnv
mb_tce forall a. Maybe a -> a -> a
`orElse` CpeTyCoEnv
emptyTCE
cpSubstTy :: CorePrepEnv -> Type -> Type
cpSubstTy :: CorePrepEnv -> Type -> Type
cpSubstTy (CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_env }) Type
ty
= case Maybe CpeTyCoEnv
mb_env of
Just CpeTyCoEnv
env -> forall a. Identity a -> a
runIdentity (CpeTyCoEnv -> Type -> Identity Type
subst_ty CpeTyCoEnv
env Type
ty)
Maybe CpeTyCoEnv
Nothing -> Type
ty
cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
cpSubstCo (CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_env }) Coercion
co
= case Maybe CpeTyCoEnv
mb_env of
Just CpeTyCoEnv
tce -> forall a. Identity a -> a
runIdentity (CpeTyCoEnv -> Coercion -> Identity Coercion
subst_co CpeTyCoEnv
tce Coercion
co)
Maybe CpeTyCoEnv
Nothing -> Coercion
co
subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity
subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity
subst_tyco_mapper = TyCoMapper
{ tcm_tyvar :: CpeTyCoEnv -> Id -> Identity Type
tcm_tyvar = \CpeTyCoEnv
env Id
tv -> forall (m :: * -> *) a. Monad m => a -> m a
return (CpeTyCoEnv -> Id -> Type
lookup_tce_tv CpeTyCoEnv
env Id
tv)
, tcm_covar :: CpeTyCoEnv -> Id -> Identity Coercion
tcm_covar = \CpeTyCoEnv
env Id
cv -> forall (m :: * -> *) a. Monad m => a -> m a
return (CpeTyCoEnv -> Id -> Coercion
lookup_tce_cv CpeTyCoEnv
env Id
cv)
, tcm_hole :: CpeTyCoEnv -> CoercionHole -> Identity Coercion
tcm_hole = \CpeTyCoEnv
_ CoercionHole
hole -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"subst_co_mapper:hole" (forall a. Outputable a => a -> SDoc
ppr CoercionHole
hole)
, tcm_tycobinder :: CpeTyCoEnv -> Id -> ArgFlag -> Identity (CpeTyCoEnv, Id)
tcm_tycobinder = \CpeTyCoEnv
env Id
tcv ArgFlag
_vis -> if Id -> Bool
isTyVar Id
tcv
then forall (m :: * -> *) a. Monad m => a -> m a
return (CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_tv_bndr CpeTyCoEnv
env Id
tcv)
else forall (m :: * -> *) a. Monad m => a -> m a
return (CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_cv_bndr CpeTyCoEnv
env Id
tcv)
, tcm_tycon :: TyCon -> Identity TyCon
tcm_tycon = \TyCon
tc -> forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc }
subst_ty :: CpeTyCoEnv -> Type -> Identity Type
subst_co :: CpeTyCoEnv -> Coercion -> Identity Coercion
(CpeTyCoEnv -> Type -> Identity Type
subst_ty, CpeTyCoEnv -> [Type] -> Identity [Type]
_, CpeTyCoEnv -> Coercion -> Identity Coercion
subst_co, CpeTyCoEnv -> [Coercion] -> Identity [Coercion]
_) = forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m
-> (env -> Type -> m Type, env -> [Type] -> m [Type],
env -> Coercion -> m Coercion, env -> [Coercion] -> m [Coercion])
mapTyCoX TyCoMapper CpeTyCoEnv Identity
subst_tyco_mapper
cpSubstTyVarBndr :: CorePrepEnv -> TyVar -> (CorePrepEnv, TyVar)
cpSubstTyVarBndr :: CorePrepEnv -> Id -> (CorePrepEnv, Id)
cpSubstTyVarBndr env :: CorePrepEnv
env@(CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_env }) Id
tv
= case Maybe CpeTyCoEnv
mb_env of
Maybe CpeTyCoEnv
Nothing -> (CorePrepEnv
env, Id
tv)
Just CpeTyCoEnv
tce -> (CorePrepEnv
env { cpe_tyco_env :: Maybe CpeTyCoEnv
cpe_tyco_env = forall a. a -> Maybe a
Just CpeTyCoEnv
tce' }, Id
tv')
where
(CpeTyCoEnv
tce', Id
tv') = CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_tv_bndr CpeTyCoEnv
tce Id
tv
subst_tv_bndr :: CpeTyCoEnv -> TyVar -> (CpeTyCoEnv, TyVar)
subst_tv_bndr :: CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_tv_bndr CpeTyCoEnv
tce Id
tv
= (CpeTyCoEnv -> Id -> Type -> CpeTyCoEnv
extend_tce_tv CpeTyCoEnv
tce Id
tv (Id -> Type
mkTyVarTy Id
tv'), Id
tv')
where
tv' :: Id
tv' = Name -> Type -> Id
mkTyVar (Id -> Name
tyVarName Id
tv) Type
kind'
kind' :: Type
kind' = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ CpeTyCoEnv -> Type -> Identity Type
subst_ty CpeTyCoEnv
tce forall a b. (a -> b) -> a -> b
$ Id -> Type
tyVarKind Id
tv
cpSubstCoVarBndr :: CorePrepEnv -> CoVar -> (CorePrepEnv, CoVar)
cpSubstCoVarBndr :: CorePrepEnv -> Id -> (CorePrepEnv, Id)
cpSubstCoVarBndr env :: CorePrepEnv
env@(CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_env }) Id
cv
= case Maybe CpeTyCoEnv
mb_env of
Maybe CpeTyCoEnv
Nothing -> (CorePrepEnv
env, Id
cv)
Just CpeTyCoEnv
tce -> (CorePrepEnv
env { cpe_tyco_env :: Maybe CpeTyCoEnv
cpe_tyco_env = forall a. a -> Maybe a
Just CpeTyCoEnv
tce' }, Id
cv')
where
(CpeTyCoEnv
tce', Id
cv') = CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_cv_bndr CpeTyCoEnv
tce Id
cv
subst_cv_bndr :: CpeTyCoEnv -> CoVar -> (CpeTyCoEnv, CoVar)
subst_cv_bndr :: CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_cv_bndr CpeTyCoEnv
tce Id
cv
= (CpeTyCoEnv -> Id -> Coercion -> CpeTyCoEnv
extend_tce_cv CpeTyCoEnv
tce Id
cv (Id -> Coercion
mkCoVarCo Id
cv'), Id
cv')
where
cv' :: Id
cv' = Name -> Type -> Id
mkCoVar (Id -> Name
varName Id
cv) Type
ty'
ty' :: Type
ty' = forall a. Identity a -> a
runIdentity (CpeTyCoEnv -> Type -> Identity Type
subst_ty CpeTyCoEnv
tce forall a b. (a -> b) -> a -> b
$ Id -> Type
varType Id
cv)
cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
cpCloneBndrs :: CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bs = forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env [Id]
bs
cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
cpCloneBndr :: CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env Id
bndr
| Id -> Bool
isTyVar Id
bndr
= forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> Id -> (CorePrepEnv, Id)
cpSubstTyVarBndr CorePrepEnv
env Id
bndr)
| Id -> Bool
isCoVar Id
bndr
= forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> Id -> (CorePrepEnv, Id)
cpSubstCoVarBndr CorePrepEnv
env Id
bndr)
| Bool
otherwise
= do { Id
bndr' <- Id -> UniqSM Id
clone_it Id
bndr
; let unfolding' :: Unfolding
unfolding' = Unfolding -> Unfolding
zapUnfolding (Id -> Unfolding
realIdUnfolding Id
bndr)
bndr'' :: Id
bndr'' = Id
bndr' Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
unfolding'
Id -> RuleInfo -> Id
`setIdSpecialisation` RuleInfo
emptyRuleInfo
; forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env Id
bndr Id
bndr'', Id
bndr'') }
where
clone_it :: Id -> UniqSM Id
clone_it Id
bndr
| Id -> Bool
isLocalId Id
bndr
= do { Unique
uniq <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let ty' :: Type
ty' = CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env (Id -> Type
idType Id
bndr)
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Unique -> Id
setVarUnique (Id -> Type -> Id
setIdType Id
bndr Type
ty') Unique
uniq) }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return Id
bndr
fiddleCCall :: Id -> UniqSM Id
fiddleCCall :: Id -> UniqSM Id
fiddleCCall Id
id
| Id -> Bool
isFCallId Id
id = (Id
id Id -> Unique -> Id
`setVarUnique`) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Id
id
newVar :: Type -> UniqSM Id
newVar :: Type -> UniqSM Id
newVar Type
ty
= Type -> ()
seqType Type
ty seq :: forall a b. a -> b -> b
`seq` do
Unique
uniq <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> Unique -> Type -> Type -> Id
mkSysLocalOrCoVar (String -> FastString
fsLit String
"sat") Unique
uniq Type
Many Type
ty)
wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
wrapTicks :: Floats -> CpeBody -> (Floats, CpeBody)
wrapTicks (Floats OkToSpec
flag OrdList FloatingBind
floats0) CpeBody
expr =
(OkToSpec -> OrdList FloatingBind -> Floats
Floats OkToSpec
flag (forall a. [a] -> OrdList a
toOL forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [FloatingBind]
floats1), forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CpeBody -> CpeBody
mkTick CpeBody
expr (forall a. [a] -> [a]
reverse [CoreTickish]
ticks1))
where ([FloatingBind]
floats1, [CoreTickish]
ticks1) = forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL ([FloatingBind], [CoreTickish])
-> FloatingBind -> ([FloatingBind], [CoreTickish])
go ([], []) forall a b. (a -> b) -> a -> b
$ OrdList FloatingBind
floats0
go :: ([FloatingBind], [CoreTickish])
-> FloatingBind -> ([FloatingBind], [CoreTickish])
go ([FloatingBind]
floats, [CoreTickish]
ticks) (FloatTick CoreTickish
t)
= ASSERT(tickishPlace t == PlaceNonLam)
([FloatingBind]
floats, if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (pass :: TickishPass).
Eq (GenTickish pass) =>
GenTickish pass -> GenTickish pass -> Bool
tickishContains CoreTickish
t) [CoreTickish]
ticks
then [CoreTickish]
ticks else CoreTickish
tforall a. a -> [a] -> [a]
:[CoreTickish]
ticks)
go ([FloatingBind]
floats, [CoreTickish]
ticks) FloatingBind
f
= (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> FloatingBind -> FloatingBind
wrap FloatingBind
f (forall a. [a] -> [a]
reverse [CoreTickish]
ticks)forall a. a -> [a] -> [a]
:[FloatingBind]
floats, [CoreTickish]
ticks)
wrap :: CoreTickish -> FloatingBind -> FloatingBind
wrap CoreTickish
t (FloatLet CoreBind
bind) = CoreBind -> FloatingBind
FloatLet (CoreTickish -> CoreBind -> CoreBind
wrapBind CoreTickish
t CoreBind
bind)
wrap CoreTickish
t (FloatCase CpeBody
r Id
b AltCon
con [Id]
bs Bool
ok) = CpeBody -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase (CoreTickish -> CpeBody -> CpeBody
mkTick CoreTickish
t CpeBody
r) Id
b AltCon
con [Id]
bs Bool
ok
wrap CoreTickish
_ FloatingBind
other = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"wrapTicks: unexpected float!"
(forall a. Outputable a => a -> SDoc
ppr FloatingBind
other)
wrapBind :: CoreTickish -> CoreBind -> CoreBind
wrapBind CoreTickish
t (NonRec Id
binder CpeBody
rhs) = forall b. b -> Expr b -> Bind b
NonRec Id
binder (CoreTickish -> CpeBody -> CpeBody
mkTick CoreTickish
t CpeBody
rhs)
wrapBind CoreTickish
t (Rec [(Id, CpeBody)]
pairs) = forall b. [(b, Expr b)] -> Bind b
Rec (forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd (CoreTickish -> CpeBody -> CpeBody
mkTick CoreTickish
t) [(Id, CpeBody)]
pairs)
collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre
collectCostCentres :: Module -> CoreProgram -> Set CostCentre
collectCostCentres Module
mod_name
= forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set CostCentre -> CoreBind -> Set CostCentre
go_bind forall a. Set a
S.empty
where
go :: Set CostCentre -> CpeBody -> Set CostCentre
go Set CostCentre
cs CpeBody
e = case CpeBody
e of
Var{} -> Set CostCentre
cs
Lit{} -> Set CostCentre
cs
App CpeBody
e1 CpeBody
e2 -> Set CostCentre -> CpeBody -> Set CostCentre
go (Set CostCentre -> CpeBody -> Set CostCentre
go Set CostCentre
cs CpeBody
e1) CpeBody
e2
Lam Id
_ CpeBody
e -> Set CostCentre -> CpeBody -> Set CostCentre
go Set CostCentre
cs CpeBody
e
Let CoreBind
b CpeBody
e -> Set CostCentre -> CpeBody -> Set CostCentre
go (Set CostCentre -> CoreBind -> Set CostCentre
go_bind Set CostCentre
cs CoreBind
b) CpeBody
e
Case CpeBody
scrt Id
_ Type
_ [Alt Id]
alts -> Set CostCentre -> [Alt Id] -> Set CostCentre
go_alts (Set CostCentre -> CpeBody -> Set CostCentre
go Set CostCentre
cs CpeBody
scrt) [Alt Id]
alts
Cast CpeBody
e Coercion
_ -> Set CostCentre -> CpeBody -> Set CostCentre
go Set CostCentre
cs CpeBody
e
Tick (ProfNote CostCentre
cc Bool
_ Bool
_) CpeBody
e ->
Set CostCentre -> CpeBody -> Set CostCentre
go (if CostCentre -> Module -> Bool
ccFromThisModule CostCentre
cc Module
mod_name then forall a. Ord a => a -> Set a -> Set a
S.insert CostCentre
cc Set CostCentre
cs else Set CostCentre
cs) CpeBody
e
Tick CoreTickish
_ CpeBody
e -> Set CostCentre -> CpeBody -> Set CostCentre
go Set CostCentre
cs CpeBody
e
Type{} -> Set CostCentre
cs
Coercion{} -> Set CostCentre
cs
go_alts :: Set CostCentre -> [Alt Id] -> Set CostCentre
go_alts = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Set CostCentre
cs (Alt AltCon
_con [Id]
_bndrs CpeBody
e) -> Set CostCentre -> CpeBody -> Set CostCentre
go Set CostCentre
cs CpeBody
e)
go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre
go_bind :: Set CostCentre -> CoreBind -> Set CostCentre
go_bind Set CostCentre
cs (NonRec Id
b CpeBody
e) =
Set CostCentre -> CpeBody -> Set CostCentre
go (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set CostCentre
cs (Set CostCentre -> CpeBody -> Set CostCentre
go Set CostCentre
cs) (Id -> Maybe CpeBody
get_unf Id
b)) CpeBody
e
go_bind Set CostCentre
cs (Rec [(Id, CpeBody)]
bs) =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Set CostCentre
cs' (Id
b, CpeBody
e) -> Set CostCentre -> CpeBody -> Set CostCentre
go (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set CostCentre
cs' (Set CostCentre -> CpeBody -> Set CostCentre
go Set CostCentre
cs') (Id -> Maybe CpeBody
get_unf Id
b)) CpeBody
e) Set CostCentre
cs [(Id, CpeBody)]
bs
get_unf :: Id -> Maybe CpeBody
get_unf = Unfolding -> Maybe CpeBody
maybeUnfoldingTemplate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Unfolding
realIdUnfolding
mkConvertNumLiteral
:: HscEnv
-> IO (LitNumType -> Integer -> Maybe CoreExpr)
mkConvertNumLiteral :: HscEnv -> IO (LitNumType -> Integer -> Maybe CpeBody)
mkConvertNumLiteral HscEnv
hsc_env = do
let
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
guardBignum :: IO Id -> IO Id
guardBignum IO Id
act
| HomeUnit -> UnitId -> Bool
isHomeUnitInstanceOf HomeUnit
home_unit UnitId
primUnitId
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. String -> a
panic String
"Bignum literals are not supported in ghc-prim"
| HomeUnit -> UnitId -> Bool
isHomeUnitInstanceOf HomeUnit
home_unit UnitId
bignumUnitId
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. String -> a
panic String
"Bignum literals are not supported in ghc-bignum"
| Bool
otherwise = IO Id
act
lookupBignumId :: Name -> IO Id
lookupBignumId Name
n = IO Id -> IO Id
guardBignum (HasDebugCallStack => TyThing -> Id
tyThingId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
n)
Id
bignatFromWordListId <- Name -> IO Id
lookupBignumId Name
bignatFromWordListName
let
convertNumLit :: LitNumType -> Integer -> Maybe CpeBody
convertNumLit LitNumType
nt Integer
i = case LitNumType
nt of
LitNumType
LitNumInteger -> forall a. a -> Maybe a
Just (Integer -> CpeBody
convertInteger Integer
i)
LitNumType
LitNumNatural -> forall a. a -> Maybe a
Just (Integer -> CpeBody
convertNatural Integer
i)
LitNumType
_ -> forall a. Maybe a
Nothing
convertInteger :: Integer -> CpeBody
convertInteger Integer
i
| Platform -> Integer -> Bool
platformInIntRange Platform
platform Integer
i
= forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
integerISDataCon [forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitInt Platform
platform Integer
i)]
| Bool
otherwise
= let con :: DataCon
con = if Integer
i forall a. Ord a => a -> a -> Bool
> Integer
0 then DataCon
integerIPDataCon else DataCon
integerINDataCon
in DataCon -> CpeBody -> CpeBody
mkBigNum DataCon
con (Integer -> CpeBody
convertBignatPrim (forall a. Num a => a -> a
abs Integer
i))
convertNatural :: Integer -> CpeBody
convertNatural Integer
i
| Platform -> Integer -> Bool
platformInWordRange Platform
platform Integer
i
= forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
naturalNSDataCon [forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitWord Platform
platform Integer
i)]
| Bool
otherwise
= DataCon -> CpeBody -> CpeBody
mkBigNum DataCon
naturalNBDataCon (Integer -> CpeBody
convertBignatPrim Integer
i)
mkBigNum :: DataCon -> CpeBody -> CpeBody
mkBigNum DataCon
con CpeBody
ba = CpeBody -> [CpeBody] -> CpeBody
mkCoreApps (forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
con)) [CpeBody
ba]
convertBignatPrim :: Integer -> CpeBody
convertBignatPrim Integer
i =
let
target :: Platform
target = DynFlags -> Platform
targetPlatform DynFlags
dflags
words :: CpeBody
words = Type -> [CpeBody] -> CpeBody
mkListExpr Type
wordTy (forall a. [a] -> [a]
reverse (forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr Integer -> Maybe (CpeBody, Integer)
f Integer
i))
where
f :: Integer -> Maybe (CpeBody, Integer)
f Integer
0 = forall a. Maybe a
Nothing
f Integer
x = let low :: Integer
low = Integer
x forall a. Bits a => a -> a -> a
.&. Integer
mask
high :: Integer
high = Integer
x forall a. Bits a => a -> Int -> a
`shiftR` Int
bits
in forall a. a -> Maybe a
Just (forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
wordDataCon [forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitWord Platform
platform Integer
low)], Integer
high)
bits :: Int
bits = Platform -> Int
platformWordSizeInBits Platform
target
mask :: Integer
mask = Integer
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
bits forall a. Num a => a -> a -> a
- Integer
1
in forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
bignatFromWordListId) [CpeBody
words]
forall (m :: * -> *) a. Monad m => a -> m a
return LitNumType -> Integer -> Maybe CpeBody
convertNumLit