{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CoreToStg.Prep
( corePrepPgm
, corePrepExpr
, mkConvertNumLiteral
)
where
#include "GhclibHsVersions.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.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.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.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.Id.Make ( realWorldPrimId )
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.TyThing
import GHC.Types.CostCentre ( CostCentre, ccFromThisModule )
import GHC.Types.Unique.Supply
import Data.Bits
import Data.List ( unfoldr )
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 =
DynFlags
-> SDoc
-> ((CoreProgram, Set CostCentre) -> ())
-> IO (CoreProgram, Set CostCentre)
-> IO (CoreProgram, Set CostCentre)
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags
(String -> SDoc
text String
"CorePrep"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(() -> (CoreProgram, Set CostCentre) -> ()
forall a b. a -> b -> a
const ()) (IO (CoreProgram, Set CostCentre)
-> IO (CoreProgram, Set CostCentre))
-> IO (CoreProgram, Set CostCentre)
-> IO (CoreProgram, Set CostCentre)
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 Way -> Set Way -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` DynFlags -> Set Way
ways DynFlags
dflags
= Module -> CoreProgram -> Set CostCentre
collectCostCentres Module
this_mod CoreProgram
binds
| Bool
otherwise
= Set CostCentre
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 = UniqSupply -> UniqSM CoreProgram -> CoreProgram
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (UniqSM CoreProgram -> CoreProgram)
-> UniqSM CoreProgram -> CoreProgram
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
CoreProgram -> UniqSM CoreProgram
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 []
(CoreProgram, Set CostCentre) -> IO (CoreProgram, Set CostCentre)
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
corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr HscEnv
hsc_env CoreExpr
expr = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
DynFlags -> SDoc -> (CoreExpr -> ()) -> IO CoreExpr -> IO CoreExpr
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags (String -> SDoc
text String
"CorePrep [expr]") (() -> CoreExpr -> ()
forall a b. a -> b -> a
const ()) (IO CoreExpr -> IO CoreExpr) -> IO CoreExpr -> IO CoreExpr
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 :: CoreExpr
new_expr = UniqSupply -> UniqSM CoreExpr -> CoreExpr
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
cpeBodyNF CorePrepEnv
initialCorePrepEnv CoreExpr
expr)
DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_prep String
"CorePrep" DumpFormat
FormatCore (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
new_expr)
CoreExpr -> IO CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
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
_ [] = Floats -> UniqSM Floats
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
Floats -> UniqSM Floats
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
= [ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (Name -> CoreExpr -> CoreExpr
tick_it (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
data_con) (Id -> CoreExpr
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 -> CoreExpr -> CoreExpr
tick_it Name
name
| DynFlags -> Int
debugLevel DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = CoreExpr -> CoreExpr
forall a. a -> a
id
| RealSrcSpan RealSrcSpan
span Maybe BufSpan
_ <- Name -> SrcSpan
nameSrcSpan Name
name = RealSrcSpan -> CoreExpr -> CoreExpr
tick RealSrcSpan
span
| Just String
file <- ModLocation -> Maybe String
ml_hs_file ModLocation
mod_loc = RealSrcSpan -> CoreExpr -> CoreExpr
tick (String -> RealSrcSpan
span1 String
file)
| Bool
otherwise = RealSrcSpan -> CoreExpr -> CoreExpr
tick (String -> RealSrcSpan
span1 String
"???")
where tick :: RealSrcSpan -> CoreExpr -> CoreExpr
tick RealSrcSpan
span = Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick (RealSrcSpan -> String -> Tickish Id
forall id. RealSrcSpan -> String -> Tickish id
SourceNote RealSrcSpan
span (String -> Tickish Id) -> String -> Tickish Id
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name))
span1 :: String -> RealSrcSpan
span1 String
file = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
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 CoreExpr
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
Type -> Bool
isUnliftedType (Id -> Type
idType Id
bndr)
; (Floats
floats, CoreExpr
rhs1) <- TopLevelFlag
-> RecFlag
-> Demand
-> Bool
-> CorePrepEnv
-> Id
-> CoreExpr
-> UniqSM (Floats, CoreExpr)
cpePair TopLevelFlag
top_lvl RecFlag
NonRecursive
Demand
dmd Bool
is_unlifted
CorePrepEnv
env Id
bndr1 CoreExpr
rhs
; let triv_rhs :: Bool
triv_rhs = CoreExpr -> Bool
cpExprIsTrivial CoreExpr
rhs1
env2 :: CorePrepEnv
env2 | Bool
triv_rhs = CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
env1 Id
bndr CoreExpr
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 -> CoreExpr -> FloatingBind
mkFloat Demand
dmd Bool
is_unlifted Id
bndr1 CoreExpr
rhs1
; (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv
env2, Floats
floats1, Maybe CoreBind
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, CoreExpr
rhs1) <- CorePrepEnv -> Id -> CoreExpr -> UniqSM (Id, CoreExpr)
cpeJoinPair CorePrepEnv
env Id
bndr1 CoreExpr
rhs
; (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env Id
bndr Id
bndr2,
Floats
emptyFloats,
CoreBind -> Maybe CoreBind
forall a. a -> Maybe a
Just (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr2 CoreExpr
rhs1)) }
cpeBind TopLevelFlag
top_lvl CorePrepEnv
env (Rec [(Id, CoreExpr)]
pairs)
| Bool -> Bool
not (Id -> Bool
isJoinId ([Id] -> Id
forall a. [a] -> a
head [Id]
bndrs))
= do { (CorePrepEnv
env', [Id]
bndrs1) <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
; [(Floats, CoreExpr)]
stuff <- (Id -> CoreExpr -> UniqSM (Floats, CoreExpr))
-> [Id] -> [CoreExpr] -> UniqSM [(Floats, CoreExpr)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TopLevelFlag
-> RecFlag
-> Demand
-> Bool
-> CorePrepEnv
-> Id
-> CoreExpr
-> UniqSM (Floats, CoreExpr)
cpePair TopLevelFlag
top_lvl RecFlag
Recursive Demand
topDmd Bool
False CorePrepEnv
env')
[Id]
bndrs1 [CoreExpr]
rhss
; let ([Floats]
floats_s, [CoreExpr]
rhss1) = [(Floats, CoreExpr)] -> ([Floats], [CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Floats, CoreExpr)]
stuff
all_pairs :: [(Id, CoreExpr)]
all_pairs = (FloatingBind -> [(Id, CoreExpr)] -> [(Id, CoreExpr)])
-> [(Id, CoreExpr)] -> OrdList FloatingBind -> [(Id, CoreExpr)]
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
add_float ([Id]
bndrs1 [Id] -> [CoreExpr] -> [(Id, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreExpr]
rhss1)
([Floats] -> OrdList FloatingBind
concatFloats [Floats]
floats_s)
; (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
extendCorePrepEnvList CorePrepEnv
env ([Id]
bndrs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
bndrs1),
FloatingBind -> Floats
unitFloat (CoreBind -> FloatingBind
FloatLet ([(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CoreExpr)]
all_pairs)),
Maybe CoreBind
forall a. Maybe a
Nothing) }
| Bool
otherwise
= do { (CorePrepEnv
env', [Id]
bndrs1) <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
; [(Id, CoreExpr)]
pairs1 <- (Id -> CoreExpr -> UniqSM (Id, CoreExpr))
-> [Id] -> [CoreExpr] -> UniqSM [(Id, CoreExpr)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (CorePrepEnv -> Id -> CoreExpr -> UniqSM (Id, CoreExpr)
cpeJoinPair CorePrepEnv
env') [Id]
bndrs1 [CoreExpr]
rhss
; let bndrs2 :: [Id]
bndrs2 = ((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
pairs1
; (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
extendCorePrepEnvList CorePrepEnv
env' ([Id]
bndrs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
bndrs2),
Floats
emptyFloats,
CoreBind -> Maybe CoreBind
forall a. a -> Maybe a
Just ([(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CoreExpr)]
pairs1)) }
where
([Id]
bndrs, [CoreExpr]
rhss) = [(Id, CoreExpr)] -> ([Id], [CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CoreExpr)]
pairs
add_float :: FloatingBind -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
add_float (FloatLet (NonRec Id
b CoreExpr
r)) [(Id, CoreExpr)]
prs2 = (Id
b,CoreExpr
r) (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: [(Id, CoreExpr)]
prs2
add_float (FloatLet (Rec [(Id, CoreExpr)]
prs1)) [(Id, CoreExpr)]
prs2 = [(Id, CoreExpr)]
prs1 [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(Id, CoreExpr)]
prs2
add_float FloatingBind
b [(Id, CoreExpr)]
_ = String -> SDoc -> [(Id, CoreExpr)]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cpeBind" (FloatingBind -> SDoc
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
-> CoreExpr
-> UniqSM (Floats, CoreExpr)
cpePair TopLevelFlag
top_lvl RecFlag
is_rec Demand
dmd Bool
is_unlifted CorePrepEnv
env Id
bndr CoreExpr
rhs
= ASSERT(not (isJoinId bndr))
do { (Floats
floats1, CoreExpr
rhs1) <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeRhsE CorePrepEnv
env CoreExpr
rhs
; (Floats
floats2, CoreExpr
rhs2) <- Floats -> CoreExpr -> UniqSM (Floats, CoreExpr)
float_from_rhs Floats
floats1 CoreExpr
rhs1
; (Floats
floats3, CoreExpr
rhs3)
<- if CoreExpr -> Int
manifestArity CoreExpr
rhs1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
arity
then (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats2, Int -> CoreExpr -> CoreExpr
cpeEtaExpand Int
arity CoreExpr
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 -> CoreExpr -> FloatingBind
mkFloat Demand
topDmd Bool
False Id
v CoreExpr
rhs2
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Floats -> FloatingBind -> Floats
addFloat Floats
floats2 FloatingBind
float
, Int -> CoreExpr -> CoreExpr
cpeEtaExpand Int
arity (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
v)) })
; let (Floats
floats4, CoreExpr
rhs4) = Floats -> CoreExpr -> (Floats, CoreExpr)
wrapTicks Floats
floats3 CoreExpr
rhs3
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats4, CoreExpr
rhs4) }
where
arity :: Int
arity = Id -> Int
idArity Id
bndr
float_from_rhs :: Floats -> CoreExpr -> UniqSM (Floats, CoreExpr)
float_from_rhs Floats
floats CoreExpr
rhs
| Floats -> Bool
isEmptyFloats Floats
floats = (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CoreExpr
rhs)
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl = Floats -> CoreExpr -> UniqSM (Floats, CoreExpr)
float_top Floats
floats CoreExpr
rhs
| Bool
otherwise = Floats -> CoreExpr -> UniqSM (Floats, CoreExpr)
float_nested Floats
floats CoreExpr
rhs
float_nested :: Floats -> CoreExpr -> UniqSM (Floats, CoreExpr)
float_nested Floats
floats CoreExpr
rhs
| RecFlag -> Demand -> Bool -> Floats -> CoreExpr -> Bool
wantFloatNested RecFlag
is_rec Demand
dmd Bool
is_unlifted Floats
floats CoreExpr
rhs
= (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CoreExpr
rhs)
| Bool
otherwise = Floats -> CoreExpr -> UniqSM (Floats, CoreExpr)
dontFloat Floats
floats CoreExpr
rhs
float_top :: Floats -> CoreExpr -> UniqSM (Floats, CoreExpr)
float_top Floats
floats CoreExpr
rhs
| Floats -> Bool
allLazyTop Floats
floats
= (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CoreExpr
rhs)
| Just (Floats, CoreExpr)
floats <- Floats -> CoreExpr -> Maybe (Floats, CoreExpr)
canFloat Floats
floats CoreExpr
rhs
= (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats, CoreExpr)
floats
| Bool
otherwise
= Floats -> CoreExpr -> UniqSM (Floats, CoreExpr)
dontFloat Floats
floats CoreExpr
rhs
dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)
dontFloat :: Floats -> CoreExpr -> UniqSM (Floats, CoreExpr)
dontFloat Floats
floats1 CoreExpr
rhs
= do { (Floats
floats2, CoreExpr
body) <- CoreExpr -> UniqSM (Floats, CoreExpr)
rhsToBody CoreExpr
rhs
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Floats -> CoreExpr -> CoreExpr
wrapBinds Floats
floats1 (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
Floats -> CoreExpr -> CoreExpr
wrapBinds Floats
floats2 CoreExpr
body) }
cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
-> UniqSM (JoinId, CpeRhs)
cpeJoinPair :: CorePrepEnv -> Id -> CoreExpr -> UniqSM (Id, CoreExpr)
cpeJoinPair CorePrepEnv
env Id
bndr CoreExpr
rhs
= ASSERT(isJoinId bndr)
do { let Just Int
join_arity = Id -> Maybe Int
isJoinId_maybe Id
bndr
([Id]
bndrs, CoreExpr
body) = Int -> CoreExpr -> ([Id], CoreExpr)
forall b. Int -> Expr b -> ([b], Expr b)
collectNBinders Int
join_arity CoreExpr
rhs
; (CorePrepEnv
env', [Id]
bndrs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
; CoreExpr
body' <- CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
cpeBodyNF CorePrepEnv
env' CoreExpr
body
; let rhs' :: CoreExpr
rhs' = [Id] -> CoreExpr -> CoreExpr
mkCoreLams [Id]
bndrs' CoreExpr
body'
bndr' :: Id
bndr' = Id
bndr Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
evaldUnfolding
Id -> Int -> Id
`setIdArity` (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
bndrs
; (Id, CoreExpr) -> UniqSM (Id, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
bndr', CoreExpr
rhs') }
cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeRhsE CorePrepEnv
_env expr :: CoreExpr
expr@(Type {}) = (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CoreExpr
expr)
cpeRhsE CorePrepEnv
_env expr :: CoreExpr
expr@(Coercion {}) = (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CoreExpr
expr)
cpeRhsE CorePrepEnv
env expr :: CoreExpr
expr@(Lit (LitNumber LitNumType
nt Integer
i))
= case CorePrepEnv -> LitNumType -> Integer -> Maybe CoreExpr
cpe_convertNumLit CorePrepEnv
env LitNumType
nt Integer
i of
Maybe CoreExpr
Nothing -> (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CoreExpr
expr)
Just CoreExpr
e -> CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeRhsE CorePrepEnv
env CoreExpr
e
cpeRhsE CorePrepEnv
_env expr :: CoreExpr
expr@(Lit {}) = (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CoreExpr
expr)
cpeRhsE CorePrepEnv
env expr :: CoreExpr
expr@(Var {}) = CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeApp CorePrepEnv
env CoreExpr
expr
cpeRhsE CorePrepEnv
env expr :: CoreExpr
expr@(App {}) = CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeApp CorePrepEnv
env CoreExpr
expr
cpeRhsE CorePrepEnv
env (Let CoreBind
bind CoreExpr
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, CoreExpr
body') <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeRhsE CorePrepEnv
env' CoreExpr
body
; let expr' :: CoreExpr
expr' = case Maybe CoreBind
maybe_bind' of Just CoreBind
bind' -> CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind' CoreExpr
body'
Maybe CoreBind
Nothing -> CoreExpr
body'
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
bind_floats Floats -> Floats -> Floats
`appendFloats` Floats
body_floats, CoreExpr
expr') }
cpeRhsE CorePrepEnv
env (Tick Tickish Id
tickish CoreExpr
expr)
| Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
tickish TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceNonLam Bool -> Bool -> Bool
&& Tickish Id
tickish Tickish Id -> TickishScoping -> Bool
forall id. Tickish id -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
= do { (Floats
floats, CoreExpr
body) <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeRhsE CorePrepEnv
env CoreExpr
expr
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (FloatingBind -> Floats
unitFloat (Tickish Id -> FloatingBind
FloatTick Tickish Id
tickish) Floats -> Floats -> Floats
`appendFloats` Floats
floats, CoreExpr
body) }
| Bool
otherwise
= do { CoreExpr
body <- CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
cpeBodyNF CorePrepEnv
env CoreExpr
expr
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Tickish Id -> CoreExpr -> CoreExpr
mkTick Tickish Id
tickish' CoreExpr
body) }
where
tickish' :: Tickish Id
tickish' | Breakpoint Int
n [Id]
fvs <- Tickish Id
tickish
= Int -> [Id] -> Tickish Id
forall id. Int -> [id] -> Tickish id
Breakpoint Int
n ((Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => CoreExpr -> Id
CoreExpr -> Id
getIdFromTrivialExpr (CoreExpr -> Id) -> (Id -> CoreExpr) -> Id -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CorePrepEnv -> Id -> CoreExpr
lookupCorePrepEnv CorePrepEnv
env) [Id]
fvs)
| Bool
otherwise
= Tickish Id
tickish
cpeRhsE CorePrepEnv
env (Cast CoreExpr
expr Coercion
co)
= do { (Floats
floats, CoreExpr
expr') <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeRhsE CorePrepEnv
env CoreExpr
expr
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
expr' Coercion
co) }
cpeRhsE CorePrepEnv
env expr :: CoreExpr
expr@(Lam {})
= do { let ([Id]
bndrs,CoreExpr
body) = CoreExpr -> ([Id], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders CoreExpr
expr
; (CorePrepEnv
env', [Id]
bndrs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
; CoreExpr
body' <- CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
cpeBodyNF CorePrepEnv
env' CoreExpr
body
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bndrs' CoreExpr
body') }
cpeRhsE CorePrepEnv
env (Case CoreExpr
scrut Id
bndr Type
ty [Alt Id]
alts)
| CoreExpr -> Bool
isUnsafeEqualityProof CoreExpr
scrut
, [(AltCon
con, [Id]
bs, CoreExpr
rhs)] <- [Alt Id]
alts
= do { (Floats
floats1, CoreExpr
scrut') <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeBody CorePrepEnv
env CoreExpr
scrut
; (CorePrepEnv
env1, Id
bndr') <- CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env Id
bndr
; (CorePrepEnv
env2, [Id]
bs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env1 [Id]
bs
; (Floats
floats2, CoreExpr
rhs') <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeBody CorePrepEnv
env2 CoreExpr
rhs
; let case_float :: FloatingBind
case_float = CoreExpr -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase CoreExpr
scrut' Id
bndr' AltCon
con [Id]
bs' Bool
True
floats' :: Floats
floats' = (Floats
floats1 Floats -> FloatingBind -> Floats
`addFloat` FloatingBind
case_float)
Floats -> Floats -> Floats
`appendFloats` Floats
floats2
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats', CoreExpr
rhs') }
| Bool
otherwise
= do { (Floats
floats, CoreExpr
scrut') <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeBody CorePrepEnv
env CoreExpr
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 ([Alt Id] -> Bool
forall b. [Alt b] -> Bool
altsAreExhaustive [Alt Id]
alts)
= [Alt Id] -> Maybe CoreExpr -> [Alt Id]
forall a b. [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]
addDefault [Alt Id]
alts (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
err)
| Bool
otherwise = [Alt Id]
alts
where err :: CoreExpr
err = Id -> Type -> String -> CoreExpr
mkRuntimeErrorApp Id
rUNTIME_ERROR_ID Type
ty
String
"Bottoming expression returned"
; [Alt Id]
alts'' <- (Alt Id -> UniqSM (Alt Id)) -> [Alt Id] -> UniqSM [Alt Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CorePrepEnv -> Alt Id -> UniqSM (Alt Id)
forall a.
CorePrepEnv -> (a, [Id], CoreExpr) -> UniqSM (a, [Id], CoreExpr)
sat_alt CorePrepEnv
env') [Alt Id]
alts'
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut' Id
bndr2 Type
ty [Alt Id]
alts'') }
where
sat_alt :: CorePrepEnv -> (a, [Id], CoreExpr) -> UniqSM (a, [Id], CoreExpr)
sat_alt CorePrepEnv
env (a
con, [Id]
bs, CoreExpr
rhs)
= do { (CorePrepEnv
env2, [Id]
bs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bs
; CoreExpr
rhs' <- CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
cpeBodyNF CorePrepEnv
env2 CoreExpr
rhs
; (a, [Id], CoreExpr) -> UniqSM (a, [Id], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
con, [Id]
bs', CoreExpr
rhs') }
cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
cpeBodyNF CorePrepEnv
env CoreExpr
expr
= do { (Floats
floats, CoreExpr
body) <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeBody CorePrepEnv
env CoreExpr
expr
; CoreExpr -> UniqSM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> CoreExpr -> CoreExpr
wrapBinds Floats
floats CoreExpr
body) }
cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeBody CorePrepEnv
env CoreExpr
expr
= do { (Floats
floats1, CoreExpr
rhs) <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeRhsE CorePrepEnv
env CoreExpr
expr
; (Floats
floats2, CoreExpr
body) <- CoreExpr -> UniqSM (Floats, CoreExpr)
rhsToBody CoreExpr
rhs
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats1 Floats -> Floats -> Floats
`appendFloats` Floats
floats2, CoreExpr
body) }
rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
rhsToBody :: CoreExpr -> UniqSM (Floats, CoreExpr)
rhsToBody (Tick Tickish Id
t CoreExpr
expr)
| Tickish Id -> TickishScoping
forall id. Tickish id -> TickishScoping
tickishScoped Tickish Id
t TickishScoping -> TickishScoping -> Bool
forall a. Eq a => a -> a -> Bool
== TickishScoping
NoScope
= do { (Floats
floats, CoreExpr
expr') <- CoreExpr -> UniqSM (Floats, CoreExpr)
rhsToBody CoreExpr
expr
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, Tickish Id -> CoreExpr -> CoreExpr
mkTick Tickish Id
t CoreExpr
expr') }
rhsToBody (Cast CoreExpr
e Coercion
co)
= do { (Floats
floats, CoreExpr
e') <- CoreExpr -> UniqSM (Floats, CoreExpr)
rhsToBody CoreExpr
e
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
e' Coercion
co) }
rhsToBody expr :: CoreExpr
expr@(Lam {})
| Just CoreExpr
no_lam_result <- [Id] -> CoreExpr -> Maybe CoreExpr
tryEtaReducePrep [Id]
bndrs CoreExpr
body
= (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CoreExpr
no_lam_result)
| (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isTyVar [Id]
bndrs
= (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CoreExpr
expr)
| Bool
otherwise
= do { Id
fn <- Type -> UniqSM Id
newVar (CoreExpr -> Type
exprType CoreExpr
expr)
; let rhs :: CoreExpr
rhs = Int -> CoreExpr -> CoreExpr
cpeEtaExpand (CoreExpr -> Int
exprArity CoreExpr
expr) CoreExpr
expr
float :: FloatingBind
float = CoreBind -> FloatingBind
FloatLet (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
fn CoreExpr
rhs)
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (FloatingBind -> Floats
unitFloat FloatingBind
float, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
fn) }
where
([Id]
bndrs,CoreExpr
body) = CoreExpr -> ([Id], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders CoreExpr
expr
rhsToBody CoreExpr
expr = (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CoreExpr
expr)
data ArgInfo = CpeApp CoreArg
| CpeCast Coercion
| CpeTick (Tickish Id)
instance Outputable ArgInfo where
ppr :: ArgInfo -> SDoc
ppr (CpeApp CoreExpr
arg) = String -> SDoc
text String
"app" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
arg
ppr (CpeCast Coercion
co) = String -> SDoc
text String
"cast" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
ppr (CpeTick Tickish Id
tick) = String -> SDoc
text String
"tick" SDoc -> SDoc -> SDoc
<+> Tickish Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Tickish Id
tick
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeApp CorePrepEnv
top_env CoreExpr
expr
= do { let (CoreExpr
terminal, [ArgInfo]
args, Int
depth) = CoreExpr -> (CoreExpr, [ArgInfo], Int)
collect_args CoreExpr
expr
; CorePrepEnv
-> CoreExpr -> [ArgInfo] -> Int -> UniqSM (Floats, CoreExpr)
cpe_app CorePrepEnv
top_env CoreExpr
terminal [ArgInfo]
args Int
depth
}
where
collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)
collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)
collect_args CoreExpr
e = CoreExpr -> [ArgInfo] -> Int -> (CoreExpr, [ArgInfo], Int)
forall c.
Num c =>
CoreExpr -> [ArgInfo] -> c -> (CoreExpr, [ArgInfo], c)
go CoreExpr
e [] Int
0
where
go :: CoreExpr -> [ArgInfo] -> c -> (CoreExpr, [ArgInfo], c)
go (App CoreExpr
fun CoreExpr
arg) [ArgInfo]
as !c
depth
= CoreExpr -> [ArgInfo] -> c -> (CoreExpr, [ArgInfo], c)
go CoreExpr
fun (CoreExpr -> ArgInfo
CpeApp CoreExpr
arg ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as)
(if CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
arg then c
depth else c
depth c -> c -> c
forall a. Num a => a -> a -> a
+ c
1)
go (Cast CoreExpr
fun Coercion
co) [ArgInfo]
as c
depth
= CoreExpr -> [ArgInfo] -> c -> (CoreExpr, [ArgInfo], c)
go CoreExpr
fun (Coercion -> ArgInfo
CpeCast Coercion
co ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as) c
depth
go (Tick Tickish Id
tickish CoreExpr
fun) [ArgInfo]
as c
depth
| Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
tickish TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceNonLam
Bool -> Bool -> Bool
&& Tickish Id
tickish Tickish Id -> TickishScoping -> Bool
forall id. Tickish id -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
= CoreExpr -> [ArgInfo] -> c -> (CoreExpr, [ArgInfo], c)
go CoreExpr
fun (Tickish Id -> ArgInfo
CpeTick Tickish Id
tickish ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as) c
depth
go CoreExpr
terminal [ArgInfo]
as c
depth = (CoreExpr
terminal, [ArgInfo]
as, c
depth)
cpe_app :: CorePrepEnv
-> CoreExpr
-> [ArgInfo]
-> Int
-> UniqSM (Floats, CpeRhs)
cpe_app :: CorePrepEnv
-> CoreExpr -> [ArgInfo] -> Int -> UniqSM (Floats, CoreExpr)
cpe_app CorePrepEnv
env (Var Id
f) (CpeApp Type{} : CpeApp CoreExpr
arg : [ArgInfo]
args) Int
depth
| Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
lazyIdKey
Bool -> Bool -> Bool
|| Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
noinlineIdKey
= let (CoreExpr
terminal, [ArgInfo]
args', Int
depth') = CoreExpr -> (CoreExpr, [ArgInfo], Int)
collect_args CoreExpr
arg
in CorePrepEnv
-> CoreExpr -> [ArgInfo] -> Int -> UniqSM (Floats, CoreExpr)
cpe_app CorePrepEnv
env CoreExpr
terminal ([ArgInfo]
args' [ArgInfo] -> [ArgInfo] -> [ArgInfo]
forall a. [a] -> [a] -> [a]
++ [ArgInfo]
args) (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
depth' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
cpe_app CorePrepEnv
env (Var Id
f) (CpeApp _runtimeRep :: CoreExpr
_runtimeRep@Type{} : CpeApp _type :: CoreExpr
_type@Type{} : CpeApp CoreExpr
arg : [ArgInfo]
rest) Int
n
| Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
runRWKey
, Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
= case CoreExpr
arg of
Lam Id
s CoreExpr
body -> CorePrepEnv
-> CoreExpr -> [ArgInfo] -> Int -> UniqSM (Floats, CoreExpr)
cpe_app (CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env Id
s Id
realWorldPrimId) CoreExpr
body [ArgInfo]
rest (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2)
CoreExpr
_ -> CorePrepEnv
-> CoreExpr -> [ArgInfo] -> Int -> UniqSM (Floats, CoreExpr)
cpe_app CorePrepEnv
env CoreExpr
arg (CoreExpr -> ArgInfo
CpeApp (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
realWorldPrimId) ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
rest) (Int
nInt -> Int -> Int
forall 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 :: CoreExpr
e2 = CorePrepEnv -> Id -> CoreExpr
lookupCorePrepEnv CorePrepEnv
env Id
v1
hd :: Maybe Id
hd = CoreExpr -> Maybe Id
getIdFromTrivialExpr_maybe CoreExpr
e2
; (CoreExpr
app, Floats
floats) <- [ArgInfo]
-> CoreExpr
-> Type
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app [ArgInfo]
args CoreExpr
e2 (CoreExpr -> Type
exprType CoreExpr
e2) Floats
emptyFloats [Demand]
stricts
; Maybe Id -> CoreExpr -> Floats -> Int -> UniqSM (Floats, CoreExpr)
forall a. Maybe Id -> CoreExpr -> a -> Int -> UniqSM (a, CoreExpr)
mb_saturate Maybe Id
hd CoreExpr
app Floats
floats Int
depth }
where
stricts :: [Demand]
stricts = case Id -> StrictSig
idStrictness Id
v of
StrictSig (DmdType DmdEnv
_ [Demand]
demands Divergence
_)
| [Demand] -> Int -> Ordering
forall a. [a] -> Int -> Ordering
listLengthCmp [Demand]
demands Int
depth Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT -> [Demand]
demands
| Bool
otherwise -> []
cpe_app CorePrepEnv
env CoreExpr
fun [] Int
_ = CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeRhsE CorePrepEnv
env CoreExpr
fun
cpe_app CorePrepEnv
env CoreExpr
fun [ArgInfo]
args Int
depth
= do { (Floats
fun_floats, CoreExpr
fun') <- CorePrepEnv
-> Demand -> CoreExpr -> Type -> UniqSM (Floats, CoreExpr)
cpeArg CorePrepEnv
env Demand
evalDmd CoreExpr
fun Type
ty
; (CoreExpr
app, Floats
floats) <- [ArgInfo]
-> CoreExpr
-> Type
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app [ArgInfo]
args CoreExpr
fun' Type
ty Floats
fun_floats []
; Maybe Id -> CoreExpr -> Floats -> Int -> UniqSM (Floats, CoreExpr)
forall a. Maybe Id -> CoreExpr -> a -> Int -> UniqSM (a, CoreExpr)
mb_saturate Maybe Id
forall a. Maybe a
Nothing CoreExpr
app Floats
floats Int
depth }
where
ty :: Type
ty = CoreExpr -> Type
exprType CoreExpr
fun
mb_saturate :: Maybe Id -> CoreExpr -> a -> Int -> UniqSM (a, CoreExpr)
mb_saturate Maybe Id
head CoreExpr
app a
floats Int
depth =
case Maybe Id
head of
Just Id
fn_id -> do { CoreExpr
sat_app <- Id -> CoreExpr -> Int -> UniqSM CoreExpr
maybeSaturate Id
fn_id CoreExpr
app Int
depth
; (a, CoreExpr) -> UniqSM (a, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
floats, CoreExpr
sat_app) }
Maybe Id
_other -> (a, CoreExpr) -> UniqSM (a, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
floats, CoreExpr
app)
rebuild_app
:: [ArgInfo]
-> CpeApp
-> Type
-> Floats
-> [Demand]
-> UniqSM (CpeApp, Floats)
rebuild_app :: [ArgInfo]
-> CoreExpr
-> Type
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app [] CoreExpr
app Type
_ Floats
floats [Demand]
ss = do
MASSERT(null ss)
(CoreExpr, Floats) -> UniqSM (CoreExpr, Floats)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
app, Floats
floats)
rebuild_app (ArgInfo
a : [ArgInfo]
as) CoreExpr
fun' Type
fun_ty Floats
floats [Demand]
ss = case ArgInfo
a of
CpeApp arg :: CoreExpr
arg@(Type Type
arg_ty) ->
[ArgInfo]
-> CoreExpr
-> Type
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app [ArgInfo]
as (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun' CoreExpr
arg) (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
piResultTy Type
fun_ty Type
arg_ty) Floats
floats [Demand]
ss
CpeApp arg :: CoreExpr
arg@(Coercion {}) ->
[ArgInfo]
-> CoreExpr
-> Type
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app [ArgInfo]
as (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun' CoreExpr
arg) (Type -> Type
funResultTy Type
fun_ty) Floats
floats [Demand]
ss
CpeApp CoreExpr
arg -> do
let (Demand
ss1, [Demand]
ss_rest)
= case ([Demand]
ss, CoreExpr -> Bool
isLazyExpr CoreExpr
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, [])
(Type
_, Type
arg_ty, Type
res_ty) =
case Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
fun_ty of
Just (Type, Type, Type)
as -> (Type, Type, Type)
as
Maybe (Type, Type, Type)
Nothing -> String -> SDoc -> (Type, Type, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cpeBody" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun_ty SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr)
(Floats
fs, CoreExpr
arg') <- CorePrepEnv
-> Demand -> CoreExpr -> Type -> UniqSM (Floats, CoreExpr)
cpeArg CorePrepEnv
top_env Demand
ss1 CoreExpr
arg Type
arg_ty
[ArgInfo]
-> CoreExpr
-> Type
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app [ArgInfo]
as (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun' CoreExpr
arg') Type
res_ty (Floats
fs Floats -> Floats -> Floats
`appendFloats` Floats
floats) [Demand]
ss_rest
CpeCast Coercion
co ->
let ty2 :: Type
ty2 = Coercion -> Type
coercionRKind Coercion
co
in [ArgInfo]
-> CoreExpr
-> Type
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app [ArgInfo]
as (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
fun' Coercion
co) Type
ty2 Floats
floats [Demand]
ss
CpeTick Tickish Id
tickish ->
[ArgInfo]
-> CoreExpr
-> Type
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app [ArgInfo]
as CoreExpr
fun' Type
fun_ty (Floats -> FloatingBind -> Floats
addFloat Floats
floats (Tickish Id -> FloatingBind
FloatTick Tickish Id
tickish)) [Demand]
ss
isLazyExpr :: CoreExpr -> Bool
isLazyExpr :: CoreExpr -> Bool
isLazyExpr (Cast CoreExpr
e Coercion
_) = CoreExpr -> Bool
isLazyExpr CoreExpr
e
isLazyExpr (Tick Tickish Id
_ CoreExpr
e) = CoreExpr -> Bool
isLazyExpr CoreExpr
e
isLazyExpr (Var Id
f `App` CoreExpr
_ `App` CoreExpr
_) = Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
lazyIdKey
isLazyExpr CoreExpr
_ = Bool
False
okCpeArg :: CoreExpr -> Bool
okCpeArg :: CoreExpr -> Bool
okCpeArg (Lit Literal
_) = Bool
False
okCpeArg CoreExpr
expr = Bool -> Bool
not (CoreExpr -> Bool
cpExprIsTrivial CoreExpr
expr)
cpExprIsTrivial :: CoreExpr -> Bool
cpExprIsTrivial :: CoreExpr -> Bool
cpExprIsTrivial CoreExpr
e
| Tick Tickish Id
t CoreExpr
e <- CoreExpr
e
, Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
t)
= CoreExpr -> Bool
cpExprIsTrivial CoreExpr
e
| Case CoreExpr
scrut Id
_ Type
_ [Alt Id]
alts <- CoreExpr
e
, CoreExpr -> Bool
isUnsafeEqualityProof CoreExpr
scrut
, [(AltCon
_,[Id]
_,CoreExpr
rhs)] <- [Alt Id]
alts
= CoreExpr -> Bool
cpExprIsTrivial CoreExpr
rhs
| Bool
otherwise
= CoreExpr -> Bool
exprIsTrivial CoreExpr
e
cpeArg :: CorePrepEnv -> Demand
-> CoreArg -> Type -> UniqSM (Floats, CpeArg)
cpeArg :: CorePrepEnv
-> Demand -> CoreExpr -> Type -> UniqSM (Floats, CoreExpr)
cpeArg CorePrepEnv
env Demand
dmd CoreExpr
arg Type
arg_ty
= do { (Floats
floats1, CoreExpr
arg1) <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeRhsE CorePrepEnv
env CoreExpr
arg
; (Floats
floats2, CoreExpr
arg2) <- if Floats -> CoreExpr -> Bool
want_float Floats
floats1 CoreExpr
arg1
then (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats1, CoreExpr
arg1)
else Floats -> CoreExpr -> UniqSM (Floats, CoreExpr)
dontFloat Floats
floats1 CoreExpr
arg1
; if CoreExpr -> Bool
okCpeArg CoreExpr
arg2
then do { Id
v <- Type -> UniqSM Id
newVar Type
arg_ty
; let arg3 :: CoreExpr
arg3 = Int -> CoreExpr -> CoreExpr
cpeEtaExpand (CoreExpr -> Int
exprArity CoreExpr
arg2) CoreExpr
arg2
arg_float :: FloatingBind
arg_float = Demand -> Bool -> Id -> CoreExpr -> FloatingBind
mkFloat Demand
dmd Bool
is_unlifted Id
v CoreExpr
arg3
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> FloatingBind -> Floats
addFloat Floats
floats2 FloatingBind
arg_float, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
v) }
else (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats2, CoreExpr
arg2)
}
where
is_unlifted :: Bool
is_unlifted = HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
arg_ty
want_float :: Floats -> CoreExpr -> Bool
want_float = RecFlag -> Demand -> Bool -> Floats -> CoreExpr -> Bool
wantFloatNested RecFlag
NonRecursive Demand
dmd Bool
is_unlifted
maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
maybeSaturate :: Id -> CoreExpr -> Int -> UniqSM CoreExpr
maybeSaturate Id
fn CoreExpr
expr Int
n_args
| Id -> Bool
hasNoBinding Id
fn
= CoreExpr -> UniqSM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
sat_expr
| Bool
otherwise
= CoreExpr -> UniqSM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr
where
fn_arity :: Int
fn_arity = Id -> Int
idArity Id
fn
excess_arity :: Int
excess_arity = Int
fn_arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_args
sat_expr :: CoreExpr
sat_expr = Int -> CoreExpr -> CoreExpr
cpeEtaExpand Int
excess_arity CoreExpr
expr
cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
cpeEtaExpand :: Int -> CoreExpr -> CoreExpr
cpeEtaExpand Int
arity CoreExpr
expr
| Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = CoreExpr
expr
| Bool
otherwise = Int -> CoreExpr -> CoreExpr
etaExpand Int
arity CoreExpr
expr
tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
tryEtaReducePrep :: [Id] -> CoreExpr -> Maybe CoreExpr
tryEtaReducePrep [Id]
bndrs expr :: CoreExpr
expr@(App CoreExpr
_ CoreExpr
_)
| CoreExpr -> Bool
forall b. Expr b -> Bool
ok_to_eta_reduce CoreExpr
f
, Int
n_remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
, [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Id -> CoreExpr -> Bool) -> [Id] -> [CoreExpr] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Id -> CoreExpr -> Bool
forall b. Id -> Expr b -> Bool
ok [Id]
bndrs [CoreExpr]
last_args)
, Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> VarSet -> Bool
`elemVarSet` VarSet
fvs_remaining) [Id]
bndrs)
, CoreExpr -> Bool
exprIsHNF CoreExpr
remaining_expr
= CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
remaining_expr
where
(CoreExpr
f, [CoreExpr]
args) = CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
expr
remaining_expr :: CoreExpr
remaining_expr = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
f [CoreExpr]
remaining_args
fvs_remaining :: VarSet
fvs_remaining = CoreExpr -> VarSet
exprFreeVars CoreExpr
remaining_expr
([CoreExpr]
remaining_args, [CoreExpr]
last_args) = Int -> [CoreExpr] -> ([CoreExpr], [CoreExpr])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_remaining [CoreExpr]
args
n_remaining :: Int
n_remaining = [CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
bndrs
ok :: Id -> Expr b -> Bool
ok Id
bndr (Var Id
arg) = Id
bndr Id -> Id -> Bool
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 Tickish Id
tickish CoreExpr
e)
| Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable Tickish Id
tickish
= (CoreExpr -> CoreExpr) -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tickish Id -> CoreExpr -> CoreExpr
mkTick Tickish Id
tickish) (Maybe CoreExpr -> Maybe CoreExpr)
-> Maybe CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [Id] -> CoreExpr -> Maybe CoreExpr
tryEtaReducePrep [Id]
bndrs CoreExpr
e
tryEtaReducePrep [Id]
_ CoreExpr
_ = Maybe CoreExpr
forall a. Maybe a
Nothing
data FloatingBind
= FloatLet CoreBind
| FloatCase
CpeBody
Id
AltCon [Var]
Bool
| FloatTick (Tickish Id)
data Floats = Floats OkToSpec (OrdList FloatingBind)
instance Outputable FloatingBind where
ppr :: FloatingBind -> SDoc
ppr (FloatLet CoreBind
b) = CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
b
ppr (FloatCase CoreExpr
r Id
b AltCon
k [Id]
bs Bool
ok) = String -> SDoc
text String
"case" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
ok) SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
r
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"of"SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"@"
SDoc -> SDoc -> SDoc
<> case [Id]
bs of
[] -> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
k
[Id]
_ -> SDoc -> SDoc
parens (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
k SDoc -> SDoc -> SDoc
<+> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
bs)
ppr (FloatTick Tickish Id
t) = Tickish Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Tickish Id
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 (OkToSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr OkToSpec
flag) SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat ((FloatingBind -> SDoc) -> [FloatingBind] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OrdList FloatingBind -> [FloatingBind]
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 -> CoreExpr -> FloatingBind
mkFloat Demand
dmd Bool
is_unlifted Id
bndr CoreExpr
rhs
| Bool
is_strict
, Bool -> Bool
not Bool
is_hnf = CoreExpr -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase CoreExpr
rhs Id
bndr AltCon
DEFAULT [] (CoreExpr -> Bool
exprOkForSpeculation CoreExpr
rhs)
| Bool
is_unlifted = ASSERT2( exprOkForSpeculation rhs, ppr rhs )
CoreExpr -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase CoreExpr
rhs Id
bndr AltCon
DEFAULT [] Bool
True
| Bool
is_hnf = CoreBind -> FloatingBind
FloatLet (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr CoreExpr
rhs)
| Bool
otherwise = CoreBind -> FloatingBind
FloatLet (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec (Id -> Demand -> Id
setIdDemandInfo Id
bndr Demand
dmd) CoreExpr
rhs)
where
is_hnf :: Bool
is_hnf = CoreExpr -> Bool
exprIsHNF CoreExpr
rhs
is_strict :: Bool
is_strict = Demand -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isStrictDmd Demand
dmd
emptyFloats :: Floats
emptyFloats :: Floats
emptyFloats = OkToSpec -> OrdList FloatingBind -> Floats
Floats OkToSpec
OkToSpec OrdList FloatingBind
forall a. OrdList a
nilOL
isEmptyFloats :: Floats -> Bool
isEmptyFloats :: Floats -> Bool
isEmptyFloats (Floats OkToSpec
_ OrdList FloatingBind
bs) = OrdList FloatingBind -> Bool
forall a. OrdList a -> Bool
isNilOL OrdList FloatingBind
bs
wrapBinds :: Floats -> CpeBody -> CpeBody
wrapBinds :: Floats -> CoreExpr -> CoreExpr
wrapBinds (Floats OkToSpec
_ OrdList FloatingBind
binds) CoreExpr
body
= (FloatingBind -> CoreExpr -> CoreExpr)
-> CoreExpr -> OrdList FloatingBind -> CoreExpr
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> CoreExpr -> CoreExpr
mk_bind CoreExpr
body OrdList FloatingBind
binds
where
mk_bind :: FloatingBind -> CoreExpr -> CoreExpr
mk_bind (FloatCase CoreExpr
rhs Id
bndr AltCon
con [Id]
bs Bool
_) CoreExpr
body = CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
rhs Id
bndr (CoreExpr -> Type
exprType CoreExpr
body) [(AltCon
con,[Id]
bs,CoreExpr
body)]
mk_bind (FloatLet CoreBind
bind) CoreExpr
body = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind CoreExpr
body
mk_bind (FloatTick Tickish Id
tickish) CoreExpr
body = Tickish Id -> CoreExpr -> CoreExpr
mkTick Tickish Id
tickish CoreExpr
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 OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> a -> OrdList a
`snocOL` FloatingBind
new_float)
where
check :: FloatingBind -> OkToSpec
check (FloatLet {}) = OkToSpec
OkToSpec
check (FloatCase CoreExpr
_ 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 OrdList FloatingBind
-> OrdList FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList FloatingBind
floats2)
concatFloats :: [Floats] -> OrdList FloatingBind
concatFloats :: [Floats] -> OrdList FloatingBind
concatFloats = (Floats -> OrdList FloatingBind -> OrdList FloatingBind)
-> OrdList FloatingBind -> [Floats] -> OrdList FloatingBind
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Floats OkToSpec
_ OrdList FloatingBind
bs1) OrdList FloatingBind
bs2 -> OrdList FloatingBind
-> OrdList FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> OrdList a -> OrdList a
appOL OrdList FloatingBind
bs1 OrdList FloatingBind
bs2) OrdList FloatingBind
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)
= (FloatingBind -> CoreProgram -> CoreProgram)
-> CoreProgram -> OrdList FloatingBind -> CoreProgram
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 CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
bs
get (FloatCase CoreExpr
body Id
var AltCon
_ [Id]
_ Bool
_) CoreProgram
bs = CoreBind -> CoreBind
get_bind (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
var CoreExpr
body) CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
bs
get FloatingBind
b CoreProgram
_ = String -> SDoc -> CoreProgram
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"corePrepPgm" (FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
b)
get_bind :: CoreBind -> CoreBind
get_bind (NonRec Id
x CoreExpr
e) = Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
x (CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
e)
get_bind (Rec [(Id, CoreExpr)]
xes) = [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id
x, CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
e) | (Id
x, CoreExpr
e) <- [(Id, CoreExpr)]
xes]
canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
canFloat :: Floats -> CoreExpr -> Maybe (Floats, CoreExpr)
canFloat (Floats OkToSpec
ok_to_spec OrdList FloatingBind
fs) CoreExpr
rhs
| OkToSpec
OkToSpec <- OkToSpec
ok_to_spec
, Just OrdList FloatingBind
fs' <- OrdList FloatingBind
-> [FloatingBind] -> Maybe (OrdList FloatingBind)
go OrdList FloatingBind
forall a. OrdList a
nilOL (OrdList FloatingBind -> [FloatingBind]
forall a. OrdList a -> [a]
fromOL OrdList FloatingBind
fs)
= (Floats, CoreExpr) -> Maybe (Floats, CoreExpr)
forall a. a -> Maybe a
Just (OkToSpec -> OrdList FloatingBind -> Floats
Floats OkToSpec
OkToSpec OrdList FloatingBind
fs', CoreExpr
rhs)
| Bool
otherwise
= Maybe (Floats, CoreExpr)
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) [] = OrdList FloatingBind -> Maybe (OrdList FloatingBind)
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 OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
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 OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> a -> OrdList a
`snocOL` FloatingBind
ft) [FloatingBind]
fbs_in
go OrdList FloatingBind
_ (FloatCase{} : [FloatingBind]
_) = Maybe (OrdList FloatingBind)
forall a. Maybe a
Nothing
wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CoreExpr -> Bool
wantFloatNested RecFlag
is_rec Demand
dmd Bool
is_unlifted Floats
floats CoreExpr
rhs
= Floats -> Bool
isEmptyFloats Floats
floats
Bool -> Bool -> Bool
|| Demand -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isStrictDmd Demand
dmd
Bool -> Bool -> Bool
|| Bool
is_unlifted
Bool -> Bool -> Bool
|| (RecFlag -> Floats -> Bool
allLazyNested RecFlag
is_rec Floats
floats Bool -> Bool -> Bool
&& CoreExpr -> Bool
exprIsHNF CoreExpr
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 CoreExpr
cpe_env :: IdEnv CoreExpr
, CorePrepEnv -> LitNumType -> Integer -> Maybe CoreExpr
cpe_convertNumLit :: LitNumType -> Integer -> Maybe CoreExpr
}
mkConvertNumLiteral
:: HscEnv
-> IO (LitNumType -> Integer -> Maybe CoreExpr)
mkConvertNumLiteral :: HscEnv -> IO (LitNumType -> Integer -> Maybe CoreExpr)
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
= Id -> IO Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> IO Id) -> Id -> IO Id
forall a b. (a -> b) -> a -> b
$ String -> Id
forall a. String -> a
panic String
"Bignum literals are not supported in ghc-prim"
| HomeUnit -> UnitId -> Bool
isHomeUnitInstanceOf HomeUnit
home_unit UnitId
bignumUnitId
= Id -> IO Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> IO Id) -> Id -> IO Id
forall a b. (a -> b) -> a -> b
$ String -> Id
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
TyThing -> Id
tyThingId (TyThing -> Id) -> IO TyThing -> IO Id
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 CoreExpr
convertNumLit LitNumType
nt Integer
i = case LitNumType
nt of
LitNumType
LitNumInteger -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
convertInteger Integer
i)
LitNumType
LitNumNatural -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Integer -> CoreExpr
convertNatural Integer
i)
LitNumType
_ -> Maybe CoreExpr
forall a. Maybe a
Nothing
convertInteger :: Integer -> CoreExpr
convertInteger Integer
i
| Platform -> Integer -> Bool
platformInIntRange Platform
platform Integer
i
= DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
integerISDataCon [Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitInt Platform
platform Integer
i)]
| Bool
otherwise
= let con :: DataCon
con = if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 then DataCon
integerIPDataCon else DataCon
integerINDataCon
in DataCon -> CoreExpr -> CoreExpr
mkBigNum DataCon
con (Integer -> CoreExpr
convertBignatPrim (Integer -> Integer
forall a. Num a => a -> a
abs Integer
i))
convertNatural :: Integer -> CoreExpr
convertNatural Integer
i
| Platform -> Integer -> Bool
platformInWordRange Platform
platform Integer
i
= DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
naturalNSDataCon [Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitWord Platform
platform Integer
i)]
| Bool
otherwise
= DataCon -> CoreExpr -> CoreExpr
mkBigNum DataCon
naturalNBDataCon (Integer -> CoreExpr
convertBignatPrim Integer
i)
mkBigNum :: DataCon -> CoreExpr -> CoreExpr
mkBigNum DataCon
con CoreExpr
ba = CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
con)) [CoreExpr
ba]
convertBignatPrim :: Integer -> CoreExpr
convertBignatPrim Integer
i =
let
target :: Platform
target = DynFlags -> Platform
targetPlatform DynFlags
dflags
words :: CoreExpr
words = Type -> [CoreExpr] -> CoreExpr
mkListExpr Type
wordTy ([CoreExpr] -> [CoreExpr]
forall a. [a] -> [a]
reverse ((Integer -> Maybe (CoreExpr, Integer)) -> Integer -> [CoreExpr]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr Integer -> Maybe (CoreExpr, Integer)
f Integer
i))
where
f :: Integer -> Maybe (CoreExpr, Integer)
f Integer
0 = Maybe (CoreExpr, Integer)
forall a. Maybe a
Nothing
f Integer
x = let low :: Integer
low = Integer
x Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
mask
high :: Integer
high = Integer
x Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
bits
in (CoreExpr, Integer) -> Maybe (CoreExpr, Integer)
forall a. a -> Maybe a
Just (DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
wordDataCon [Literal -> CoreExpr
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 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
bits Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
in CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bignatFromWordListId) [CoreExpr
words]
(LitNumType -> Integer -> Maybe CoreExpr)
-> IO (LitNumType -> Integer -> Maybe CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return LitNumType -> Integer -> Maybe CoreExpr
convertNumLit
mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv HscEnv
hsc_env = do
LitNumType -> Integer -> Maybe CoreExpr
convertNumLit <- HscEnv -> IO (LitNumType -> Integer -> Maybe CoreExpr)
mkConvertNumLiteral HscEnv
hsc_env
CorePrepEnv -> IO CorePrepEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> IO CorePrepEnv) -> CorePrepEnv -> IO CorePrepEnv
forall a b. (a -> b) -> a -> b
$ CPE :: DynFlags
-> IdEnv CoreExpr
-> (LitNumType -> Integer -> Maybe CoreExpr)
-> CorePrepEnv
CPE
{ cpe_dynFlags :: DynFlags
cpe_dynFlags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
, cpe_env :: IdEnv CoreExpr
cpe_env = IdEnv CoreExpr
forall a. VarEnv a
emptyVarEnv
, cpe_convertNumLit :: LitNumType -> Integer -> Maybe CoreExpr
cpe_convertNumLit = LitNumType -> Integer -> Maybe CoreExpr
convertNumLit
}
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
cpe Id
id Id
id'
= CorePrepEnv
cpe { cpe_env :: IdEnv CoreExpr
cpe_env = IdEnv CoreExpr -> Id -> CoreExpr -> IdEnv CoreExpr
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (CorePrepEnv -> IdEnv CoreExpr
cpe_env CorePrepEnv
cpe) Id
id (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
id') }
extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
cpe Id
id CoreExpr
expr
= CorePrepEnv
cpe { cpe_env :: IdEnv CoreExpr
cpe_env = IdEnv CoreExpr -> Id -> CoreExpr -> IdEnv CoreExpr
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (CorePrepEnv -> IdEnv CoreExpr
cpe_env CorePrepEnv
cpe) Id
id CoreExpr
expr }
extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
extendCorePrepEnvList :: CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
extendCorePrepEnvList CorePrepEnv
cpe [(Id, Id)]
prs
= CorePrepEnv
cpe { cpe_env :: IdEnv CoreExpr
cpe_env = IdEnv CoreExpr -> [(Id, CoreExpr)] -> IdEnv CoreExpr
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList (CorePrepEnv -> IdEnv CoreExpr
cpe_env CorePrepEnv
cpe)
(((Id, Id) -> (Id, CoreExpr)) -> [(Id, Id)] -> [(Id, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
id, Id
id') -> (Id
id, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
id')) [(Id, Id)]
prs) }
lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
lookupCorePrepEnv CorePrepEnv
cpe Id
id
= case IdEnv CoreExpr -> Id -> Maybe CoreExpr
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (CorePrepEnv -> IdEnv CoreExpr
cpe_env CorePrepEnv
cpe) Id
id of
Maybe CoreExpr
Nothing -> Id -> CoreExpr
forall b. Id -> Expr b
Var Id
id
Just CoreExpr
exp -> CoreExpr
exp
cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
cpCloneBndrs :: CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bs = (CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id))
-> CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
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
| Bool -> Bool
not (Id -> Bool
isId Id
bndr)
= (CorePrepEnv, Id) -> UniqSM (CorePrepEnv, Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv
env, Id
bndr)
| Bool
otherwise
= do { Id
bndr' <- Id -> UniqSM Id
forall (m :: * -> *). MonadUnique m => Id -> m 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
; (CorePrepEnv, Id) -> UniqSM (CorePrepEnv, Id)
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 -> m Id
clone_it Id
bndr
| Id -> Bool
isLocalId Id
bndr, Bool -> Bool
not (Id -> Bool
isCoVar Id
bndr)
= do { Unique
uniq <- m Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM; Id -> m Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Unique -> Id
setVarUnique Id
bndr Unique
uniq) }
| Bool
otherwise
= Id -> m Id
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`) (Unique -> Id) -> UniqSM Unique -> UniqSM Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
| Bool
otherwise = Id -> UniqSM Id
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 () -> UniqSM Id -> UniqSM Id
`seq` do
Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
Id -> UniqSM Id
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 -> CoreExpr -> (Floats, CoreExpr)
wrapTicks (Floats OkToSpec
flag OrdList FloatingBind
floats0) CoreExpr
expr =
(OkToSpec -> OrdList FloatingBind -> Floats
Floats OkToSpec
flag ([FloatingBind] -> OrdList FloatingBind
forall a. [a] -> OrdList a
toOL ([FloatingBind] -> OrdList FloatingBind)
-> [FloatingBind] -> OrdList FloatingBind
forall a b. (a -> b) -> a -> b
$ [FloatingBind] -> [FloatingBind]
forall a. [a] -> [a]
reverse [FloatingBind]
floats1), (Tickish Id -> CoreExpr -> CoreExpr)
-> CoreExpr -> [Tickish Id] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tickish Id -> CoreExpr -> CoreExpr
mkTick CoreExpr
expr ([Tickish Id] -> [Tickish Id]
forall a. [a] -> [a]
reverse [Tickish Id]
ticks1))
where ([FloatingBind]
floats1, [Tickish Id]
ticks1) = (([FloatingBind], [Tickish Id])
-> FloatingBind -> ([FloatingBind], [Tickish Id]))
-> ([FloatingBind], [Tickish Id])
-> OrdList FloatingBind
-> ([FloatingBind], [Tickish Id])
forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL ([FloatingBind], [Tickish Id])
-> FloatingBind -> ([FloatingBind], [Tickish Id])
go ([], []) (OrdList FloatingBind -> ([FloatingBind], [Tickish Id]))
-> OrdList FloatingBind -> ([FloatingBind], [Tickish Id])
forall a b. (a -> b) -> a -> b
$ OrdList FloatingBind
floats0
go :: ([FloatingBind], [Tickish Id])
-> FloatingBind -> ([FloatingBind], [Tickish Id])
go ([FloatingBind]
floats, [Tickish Id]
ticks) (FloatTick Tickish Id
t)
= ASSERT(tickishPlace t == PlaceNonLam)
([FloatingBind]
floats, if (Tickish Id -> Bool) -> [Tickish Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Tickish Id -> Tickish Id -> Bool)
-> Tickish Id -> Tickish Id -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Tickish Id -> Tickish Id -> Bool
forall b. Eq b => Tickish b -> Tickish b -> Bool
tickishContains Tickish Id
t) [Tickish Id]
ticks
then [Tickish Id]
ticks else Tickish Id
tTickish Id -> [Tickish Id] -> [Tickish Id]
forall a. a -> [a] -> [a]
:[Tickish Id]
ticks)
go ([FloatingBind]
floats, [Tickish Id]
ticks) FloatingBind
f
= ((Tickish Id -> FloatingBind -> FloatingBind)
-> FloatingBind -> [Tickish Id] -> FloatingBind
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tickish Id -> FloatingBind -> FloatingBind
wrap FloatingBind
f ([Tickish Id] -> [Tickish Id]
forall a. [a] -> [a]
reverse [Tickish Id]
ticks)FloatingBind -> [FloatingBind] -> [FloatingBind]
forall a. a -> [a] -> [a]
:[FloatingBind]
floats, [Tickish Id]
ticks)
wrap :: Tickish Id -> FloatingBind -> FloatingBind
wrap Tickish Id
t (FloatLet CoreBind
bind) = CoreBind -> FloatingBind
FloatLet (Tickish Id -> CoreBind -> CoreBind
wrapBind Tickish Id
t CoreBind
bind)
wrap Tickish Id
t (FloatCase CoreExpr
r Id
b AltCon
con [Id]
bs Bool
ok) = CoreExpr -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase (Tickish Id -> CoreExpr -> CoreExpr
mkTick Tickish Id
t CoreExpr
r) Id
b AltCon
con [Id]
bs Bool
ok
wrap Tickish Id
_ FloatingBind
other = String -> SDoc -> FloatingBind
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"wrapTicks: unexpected float!"
(FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
other)
wrapBind :: Tickish Id -> CoreBind -> CoreBind
wrapBind Tickish Id
t (NonRec Id
binder CoreExpr
rhs) = Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
binder (Tickish Id -> CoreExpr -> CoreExpr
mkTick Tickish Id
t CoreExpr
rhs)
wrapBind Tickish Id
t (Rec [(Id, CoreExpr)]
pairs) = [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ((CoreExpr -> CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd (Tickish Id -> CoreExpr -> CoreExpr
mkTick Tickish Id
t) [(Id, CoreExpr)]
pairs)
collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre
collectCostCentres :: Module -> CoreProgram -> Set CostCentre
collectCostCentres Module
mod_name
= (Set CostCentre -> CoreBind -> Set CostCentre)
-> Set CostCentre -> CoreProgram -> Set CostCentre
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set CostCentre -> CoreBind -> Set CostCentre
go_bind Set CostCentre
forall a. Set a
S.empty
where
go :: Set CostCentre -> CoreExpr -> Set CostCentre
go Set CostCentre
cs CoreExpr
e = case CoreExpr
e of
Var{} -> Set CostCentre
cs
Lit{} -> Set CostCentre
cs
App CoreExpr
e1 CoreExpr
e2 -> Set CostCentre -> CoreExpr -> Set CostCentre
go (Set CostCentre -> CoreExpr -> Set CostCentre
go Set CostCentre
cs CoreExpr
e1) CoreExpr
e2
Lam Id
_ CoreExpr
e -> Set CostCentre -> CoreExpr -> Set CostCentre
go Set CostCentre
cs CoreExpr
e
Let CoreBind
b CoreExpr
e -> Set CostCentre -> CoreExpr -> Set CostCentre
go (Set CostCentre -> CoreBind -> Set CostCentre
go_bind Set CostCentre
cs CoreBind
b) CoreExpr
e
Case CoreExpr
scrt Id
_ Type
_ [Alt Id]
alts -> Set CostCentre -> [Alt Id] -> Set CostCentre
go_alts (Set CostCentre -> CoreExpr -> Set CostCentre
go Set CostCentre
cs CoreExpr
scrt) [Alt Id]
alts
Cast CoreExpr
e Coercion
_ -> Set CostCentre -> CoreExpr -> Set CostCentre
go Set CostCentre
cs CoreExpr
e
Tick (ProfNote CostCentre
cc Bool
_ Bool
_) CoreExpr
e ->
Set CostCentre -> CoreExpr -> Set CostCentre
go (if CostCentre -> Module -> Bool
ccFromThisModule CostCentre
cc Module
mod_name then CostCentre -> Set CostCentre -> Set CostCentre
forall a. Ord a => a -> Set a -> Set a
S.insert CostCentre
cc Set CostCentre
cs else Set CostCentre
cs) CoreExpr
e
Tick Tickish Id
_ CoreExpr
e -> Set CostCentre -> CoreExpr -> Set CostCentre
go Set CostCentre
cs CoreExpr
e
Type{} -> Set CostCentre
cs
Coercion{} -> Set CostCentre
cs
go_alts :: Set CostCentre -> [Alt Id] -> Set CostCentre
go_alts = (Set CostCentre -> Alt Id -> Set CostCentre)
-> Set CostCentre -> [Alt Id] -> Set CostCentre
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Set CostCentre
cs (AltCon
_con, [Id]
_bndrs, CoreExpr
e) -> Set CostCentre -> CoreExpr -> Set CostCentre
go Set CostCentre
cs CoreExpr
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 CoreExpr
e) =
Set CostCentre -> CoreExpr -> Set CostCentre
go (Set CostCentre
-> (CoreExpr -> Set CostCentre) -> Maybe CoreExpr -> Set CostCentre
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set CostCentre
cs (Set CostCentre -> CoreExpr -> Set CostCentre
go Set CostCentre
cs) (Id -> Maybe CoreExpr
get_unf Id
b)) CoreExpr
e
go_bind Set CostCentre
cs (Rec [(Id, CoreExpr)]
bs) =
(Set CostCentre -> (Id, CoreExpr) -> Set CostCentre)
-> Set CostCentre -> [(Id, CoreExpr)] -> Set CostCentre
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Set CostCentre
cs' (Id
b, CoreExpr
e) -> Set CostCentre -> CoreExpr -> Set CostCentre
go (Set CostCentre
-> (CoreExpr -> Set CostCentre) -> Maybe CoreExpr -> Set CostCentre
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set CostCentre
cs' (Set CostCentre -> CoreExpr -> Set CostCentre
go Set CostCentre
cs') (Id -> Maybe CoreExpr
get_unf Id
b)) CoreExpr
e) Set CostCentre
cs [(Id, CoreExpr)]
bs
get_unf :: Id -> Maybe CoreExpr
get_unf = Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (Unfolding -> Maybe CoreExpr)
-> (Id -> Unfolding) -> Id -> Maybe CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Unfolding
realIdUnfolding