{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CoreToStg.Prep
( corePrepPgm
, corePrepExpr
, mkConvertNumLiteral
)
where
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.PrimOps
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId )
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.Panic.Plain
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 =
Logger
-> DynFlags
-> SDoc
-> ((CoreProgram, Set CostCentre) -> ())
-> IO (CoreProgram, Set CostCentre)
-> IO (CoreProgram, Set CostCentre)
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 (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(\(CoreProgram
a,Set CostCentre
b) -> CoreProgram
a CoreProgram -> Set CostCentre -> Set CostCentre
forall a b. [a] -> b -> b
`seqList` Set CostCentre
b Set CostCentre -> () -> ()
`seq` ()) (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
logger :: Logger
logger = HscEnv -> Logger
hsc_logger 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
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
Logger
-> DynFlags
-> SDoc
-> (CoreExpr -> ())
-> IO CoreExpr
-> IO CoreExpr
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags (String -> SDoc
text String
"CorePrep [expr]") (\CoreExpr
e -> CoreExpr
e CoreExpr -> () -> ()
`seq` ()) (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)
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger 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
Bool -> UniqSM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Maybe CoreBind -> Bool
forall a. Maybe a -> Bool
isNothing Maybe CoreBind
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 = CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (RealSrcSpan -> String -> CoreTickish
forall (pass :: TickishPass).
RealSrcSpan -> String -> GenTickish pass
SourceNote RealSrcSpan
span (String -> CoreTickish) -> String -> CoreTickish
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
exprIsTrivial 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
= Bool
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl)) (UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind))
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall a b. (a -> b) -> a -> b
$
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
= Bool -> UniqSM (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Id -> Bool
isJoinId Id
bndr)) (UniqSM (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr))
-> UniqSM (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall a b. (a -> b) -> a -> b
$
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 Bool
-> SDoc -> UniqSM (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall a. HasCallStack => Bool -> SDoc -> a -> a
warnPprTrace Bool
True (String -> SDoc
text String
"CorePrep: silly extra arguments:" SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr) (UniqSM (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr))
-> UniqSM (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall a b. (a -> b) -> a -> b
$
(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
= Bool -> UniqSM (Id, CoreExpr) -> UniqSM (Id, CoreExpr)
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isJoinId Id
bndr) (UniqSM (Id, CoreExpr) -> UniqSM (Id, CoreExpr))
-> UniqSM (Id, CoreExpr) -> UniqSM (Id, CoreExpr)
forall a b. (a -> b) -> a -> b
$
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 (Type Type
ty)
= (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Type -> CoreExpr
forall b. Type -> Expr b
Type (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty))
cpeRhsE CorePrepEnv
env (Coercion Coercion
co)
= (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion (CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co))
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 CoreTickish
tickish CoreExpr
expr)
| CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
tickish TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceNonLam Bool -> Bool -> Bool
&& CoreTickish
tickish CoreTickish -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> 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 (CoreTickish -> FloatingBind
FloatTick CoreTickish
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, CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
tickish' CoreExpr
body) }
where
tickish' :: CoreTickish
tickish' | Breakpoint XBreakpoint 'TickishPassCore
ext Int
n [XTickishId 'TickishPassCore]
fvs <- CoreTickish
tickish
= XBreakpoint 'TickishPassCore
-> Int -> [XTickishId 'TickishPassCore] -> CoreTickish
forall (pass :: TickishPass).
XBreakpoint pass -> Int -> [XTickishId pass] -> GenTickish pass
Breakpoint XBreakpoint 'TickishPassCore
ext 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]
[XTickishId 'TickishPassCore]
fvs)
| Bool
otherwise
= CoreTickish
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' (CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env 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
_ Type
ty [])
= do { (Floats
floats, CoreExpr
scrut') <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeRhsE CorePrepEnv
env CoreExpr
scrut
; let ty' :: Type
ty' = CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty
scrut_ty' :: Type
scrut_ty' = CoreExpr -> Type
exprType CoreExpr
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
; (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
scrut' Coercion
co') }
cpeRhsE CorePrepEnv
env (Case CoreExpr
scrut Id
bndr Type
_ [Alt Id]
alts)
| CoreExpr -> Bool
isUnsafeEqualityProof CoreExpr
scrut
, Id -> Bool
isDeadBinder Id
bndr
, [Alt AltCon
_ [Id
co_var] CoreExpr
rhs] <- [Alt Id]
alts
, let Pair Type
ty1 Type
ty2 = HasDebugCallStack => Id -> Pair Type
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 -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeRhsE CorePrepEnv
env' CoreExpr
rhs
cpeRhsE CorePrepEnv
env (Case CoreExpr
scrut Id
bndr Type
ty [Alt Id]
alts)
= 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 b. [Alt b] -> Maybe (Expr b) -> [Alt 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)
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 -> Alt Id -> UniqSM (Alt Id)
sat_alt CorePrepEnv
env (Alt AltCon
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
; Alt Id -> UniqSM (Alt Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
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 CoreTickish
t CoreExpr
expr)
| CoreTickish -> TickishScoping
forall (pass :: TickishPass). GenTickish pass -> TickishScoping
tickishScoped CoreTickish
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, CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
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 { let rhs :: CoreExpr
rhs = Int -> CoreExpr -> CoreExpr
cpeEtaExpand (CoreExpr -> Int
exprArity CoreExpr
expr) CoreExpr
expr
; Id
fn <- Type -> UniqSM Id
newVar (CoreExpr -> Type
exprType CoreExpr
rhs)
; let 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 CoreTickish
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 CoreTickish
tick) = String -> SDoc
text String
"tick" SDoc -> SDoc -> SDoc
<+> CoreTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreTickish
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 CoreTickish
tickish CoreExpr
fun) [ArgInfo]
as c
depth
| CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
tickish TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceNonLam
Bool -> Bool -> Bool
&& CoreTickish
tickish CoreTickish -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
= CoreExpr -> [ArgInfo] -> c -> (CoreExpr, [ArgInfo], c)
go CoreExpr
fun (CoreTickish -> ArgInfo
CpeTick CoreTickish
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)
[ArgInfo]
args
Int
n
| Just PrimOp
KeepAliveOp <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
f
, CpeApp (Type Type
arg_rep)
: CpeApp (Type Type
arg_ty)
: CpeApp (Type Type
_result_rep)
: CpeApp (Type Type
result_ty)
: CpeApp CoreExpr
arg
: CpeApp CoreExpr
s0
: CpeApp CoreExpr
k
: [ArgInfo]
rest <- [ArgInfo]
args
= do { Id
y <- Type -> UniqSM Id
newVar (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
result_ty)
; Id
s2 <- Type -> UniqSM Id
newVar Type
realWorldStatePrimTy
;
; (Floats
floats, CoreExpr
k') <- case CoreExpr
k of
Lam Id
s CoreExpr
body -> CorePrepEnv
-> CoreExpr -> [ArgInfo] -> Int -> UniqSM (Floats, CoreExpr)
cpe_app (CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
env Id
s CoreExpr
s0) 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
k (CoreExpr -> ArgInfo
CpeApp CoreExpr
s0 ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
rest) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
; let touchId :: Id
touchId = PrimOp -> Id
mkPrimOpId PrimOp
TouchOp
expr :: CoreExpr
expr = CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
k' Id
y Type
result_ty [AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
rhs]
rhs :: CoreExpr
rhs = let scrut :: CoreExpr
scrut = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
touchId) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
arg_rep, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
arg_ty, CoreExpr
arg, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
realWorldPrimId]
in CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Id
s2 Type
result_ty [AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y)]
; (Floats
floats', CoreExpr
expr') <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeBody CorePrepEnv
env CoreExpr
expr
; (Floats, CoreExpr) -> UniqSM (Floats, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats Floats -> Floats -> Floats
`appendFloats` Floats
floats', CoreExpr
expr')
}
| Just PrimOp
KeepAliveOp <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
f
= String -> UniqSM (Floats, CoreExpr)
forall a. String -> a
panic String
"invalid keepAlive# application"
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) <- CorePrepEnv
-> [ArgInfo]
-> CoreExpr
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
args 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 -> DmdSig
idDmdSig Id
v of
DmdSig (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 -> UniqSM (Floats, CoreExpr)
cpeArg CorePrepEnv
env Demand
evalDmd CoreExpr
fun
; (CoreExpr
app, Floats
floats) <- CorePrepEnv
-> [ArgInfo]
-> CoreExpr
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
args CoreExpr
fun' 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 }
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
:: CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> UniqSM (CpeApp, Floats)
rebuild_app :: CorePrepEnv
-> [ArgInfo]
-> CoreExpr
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app CorePrepEnv
_ [] CoreExpr
app Floats
floats [Demand]
ss
= Bool
-> ((CoreExpr, Floats) -> UniqSM (CoreExpr, Floats))
-> (CoreExpr, Floats)
-> UniqSM (CoreExpr, Floats)
forall a. HasCallStack => Bool -> a -> a
assert ([Demand] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Demand]
ss)
(CoreExpr, Floats) -> UniqSM (CoreExpr, Floats)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
app, Floats
floats)
rebuild_app CorePrepEnv
env (ArgInfo
a : [ArgInfo]
as) CoreExpr
fun' Floats
floats [Demand]
ss = case ArgInfo
a of
CpeApp (Type Type
arg_ty)
-> CorePrepEnv
-> [ArgInfo]
-> CoreExpr
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
as (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun' (Type -> CoreExpr
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]
-> CoreExpr
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
as (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun' (Coercion -> CoreExpr
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 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, [])
(Floats
fs, CoreExpr
arg') <- CorePrepEnv -> Demand -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeArg CorePrepEnv
top_env Demand
ss1 CoreExpr
arg
CorePrepEnv
-> [ArgInfo]
-> CoreExpr
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
as (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun' CoreExpr
arg') (Floats
fs Floats -> Floats -> Floats
`appendFloats` Floats
floats) [Demand]
ss_rest
CpeCast Coercion
co
-> CorePrepEnv
-> [ArgInfo]
-> CoreExpr
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
as (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
fun' Coercion
co') Floats
floats [Demand]
ss
where
co' :: Coercion
co' = CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co
CpeTick CoreTickish
tickish
-> CorePrepEnv
-> [ArgInfo]
-> CoreExpr
-> Floats
-> [Demand]
-> UniqSM (CoreExpr, Floats)
rebuild_app CorePrepEnv
env [ArgInfo]
as CoreExpr
fun' (Floats -> FloatingBind -> Floats
addFloat Floats
floats (CoreTickish -> FloatingBind
FloatTick CoreTickish
tickish)) [Demand]
ss
isLazyExpr :: CoreExpr -> Bool
isLazyExpr :: CoreExpr -> Bool
isLazyExpr (Cast CoreExpr
e Coercion
_) = CoreExpr -> Bool
isLazyExpr CoreExpr
e
isLazyExpr (Tick CoreTickish
_ 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
exprIsTrivial CoreExpr
expr)
cpeArg :: CorePrepEnv -> Demand
-> CoreArg -> UniqSM (Floats, CpeArg)
cpeArg :: CorePrepEnv -> Demand -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeArg CorePrepEnv
env Demand
dmd CoreExpr
arg
= do { (Floats
floats1, CoreExpr
arg1) <- CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
cpeRhsE CorePrepEnv
env CoreExpr
arg
; let arg_ty :: Type
arg_ty = CoreExpr -> Type
exprType CoreExpr
arg1
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
; (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)
}
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 CoreTickish
tickish CoreExpr
e)
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
tickish
= (CoreExpr -> CoreExpr) -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
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 CoreTickish
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 CoreTickish
t) = CoreTickish -> SDoc
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 (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 -> Bool
|| Bool
ok_for_spec
, Bool -> Bool
not Bool
is_hnf = CoreExpr -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase CoreExpr
rhs Id
bndr AltCon
DEFAULT [] Bool
ok_for_spec
| Bool
is_unlifted = 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
isStrUsedDmd Demand
dmd
ok_for_spec :: Bool
ok_for_spec = CoreExpr -> Bool
exprOkForSpeculation CoreExpr
rhs
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 -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt 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 CoreTickish
tickish) CoreExpr
body = CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
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
isStrUsedDmd 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 -> Maybe CpeTyCoEnv
cpe_tyco_env :: Maybe CpeTyCoEnv
, CorePrepEnv -> LitNumType -> Integer -> Maybe CoreExpr
cpe_convertNumLit :: LitNumType -> Integer -> Maybe CoreExpr
}
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
-> Maybe CpeTyCoEnv
-> (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_tyco_env :: Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
forall a. Maybe a
Nothing
, 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
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 (CvSubstEnv -> Id -> Coercion -> CvSubstEnv
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 (TvSubstEnv -> Id -> Type -> TvSubstEnv
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 CvSubstEnv -> Id -> Maybe Coercion
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 TvSubstEnv -> Id -> Maybe Type
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 = CpeTyCoEnv -> Maybe CpeTyCoEnv
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 Maybe CpeTyCoEnv -> CpeTyCoEnv -> CpeTyCoEnv
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 -> Identity Type -> Type
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 -> Identity Coercion -> Coercion
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 :: forall env (m :: * -> *).
(env -> Id -> m Type)
-> (env -> Id -> m Coercion)
-> (env -> CoercionHole -> m Coercion)
-> (env -> Id -> ArgFlag -> m (env, Id))
-> (TyCon -> m TyCon)
-> TyCoMapper env m
TyCoMapper
{ tcm_tyvar :: CpeTyCoEnv -> Id -> Identity Type
tcm_tyvar = \CpeTyCoEnv
env Id
tv -> Type -> Identity Type
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 -> Coercion -> Identity Coercion
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 -> String -> SDoc -> Identity Coercion
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"subst_co_mapper:hole" (CoercionHole -> SDoc
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 (CpeTyCoEnv, Id) -> Identity (CpeTyCoEnv, Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_tv_bndr CpeTyCoEnv
env Id
tcv)
else (CpeTyCoEnv, Id) -> Identity (CpeTyCoEnv, Id)
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 -> TyCon -> Identity TyCon
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]
_) = TyCoMapper CpeTyCoEnv Identity
-> (CpeTyCoEnv -> Type -> Identity Type,
CpeTyCoEnv -> [Type] -> Identity [Type],
CpeTyCoEnv -> Coercion -> Identity Coercion,
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 = CpeTyCoEnv -> Maybe CpeTyCoEnv
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' = Identity Type -> Type
forall a. Identity a -> a
runIdentity (Identity Type -> Type) -> Identity Type -> Type
forall a b. (a -> b) -> a -> b
$ CpeTyCoEnv -> Type -> Identity Type
subst_ty CpeTyCoEnv
tce (Type -> Identity Type) -> Type -> Identity Type
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 = CpeTyCoEnv -> Maybe CpeTyCoEnv
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' = Identity Type -> Type
forall a. Identity a -> a
runIdentity (CpeTyCoEnv -> Type -> Identity Type
subst_ty CpeTyCoEnv
tce (Type -> Identity Type) -> Type -> Identity Type
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 = (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
| Id -> Bool
isTyVar Id
bndr
= (CorePrepEnv, Id) -> UniqSM (CorePrepEnv, Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> Id -> (CorePrepEnv, Id)
cpSubstTyVarBndr CorePrepEnv
env Id
bndr)
| Id -> Bool
isCoVar Id
bndr
= (CorePrepEnv, Id) -> UniqSM (CorePrepEnv, Id)
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
; (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 -> UniqSM Id
clone_it Id
bndr
| Id -> Bool
isLocalId Id
bndr
= do { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let ty' :: Type
ty' = CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env (Id -> Type
idType Id
bndr)
; Id -> UniqSM Id
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
= Id -> UniqSM 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), (CoreTickish -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreTickish] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreExpr
expr ([CoreTickish] -> [CoreTickish]
forall a. [a] -> [a]
reverse [CoreTickish]
ticks1))
where ([FloatingBind]
floats1, [CoreTickish]
ticks1) = (([FloatingBind], [CoreTickish])
-> FloatingBind -> ([FloatingBind], [CoreTickish]))
-> ([FloatingBind], [CoreTickish])
-> OrdList FloatingBind
-> ([FloatingBind], [CoreTickish])
forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL ([FloatingBind], [CoreTickish])
-> FloatingBind -> ([FloatingBind], [CoreTickish])
go ([], []) (OrdList FloatingBind -> ([FloatingBind], [CoreTickish]))
-> OrdList FloatingBind -> ([FloatingBind], [CoreTickish])
forall a b. (a -> b) -> a -> b
$ OrdList FloatingBind
floats0
go :: ([FloatingBind], [CoreTickish])
-> FloatingBind -> ([FloatingBind], [CoreTickish])
go ([FloatingBind]
floats, [CoreTickish]
ticks) (FloatTick CoreTickish
t)
= Bool
-> ([FloatingBind], [CoreTickish])
-> ([FloatingBind], [CoreTickish])
forall a. HasCallStack => Bool -> a -> a
assert (CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceNonLam)
([FloatingBind]
floats, if (CoreTickish -> Bool) -> [CoreTickish] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((CoreTickish -> CoreTickish -> Bool)
-> CoreTickish -> CoreTickish -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip CoreTickish -> CoreTickish -> Bool
forall (pass :: TickishPass).
Eq (GenTickish pass) =>
GenTickish pass -> GenTickish pass -> Bool
tickishContains CoreTickish
t) [CoreTickish]
ticks
then [CoreTickish]
ticks else CoreTickish
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
ticks)
go ([FloatingBind]
floats, [CoreTickish]
ticks) FloatingBind
f
= ((CoreTickish -> FloatingBind -> FloatingBind)
-> FloatingBind -> [CoreTickish] -> FloatingBind
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> FloatingBind -> FloatingBind
wrap FloatingBind
f ([CoreTickish] -> [CoreTickish]
forall a. [a] -> [a]
reverse [CoreTickish]
ticks)FloatingBind -> [FloatingBind] -> [FloatingBind]
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 CoreExpr
r Id
b AltCon
con [Id]
bs Bool
ok) = CoreExpr -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase (CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
t CoreExpr
r) Id
b AltCon
con [Id]
bs Bool
ok
wrap CoreTickish
_ 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 :: CoreTickish -> CoreBind -> CoreBind
wrapBind CoreTickish
t (NonRec Id
binder CoreExpr
rhs) = Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
binder (CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
t CoreExpr
rhs)
wrapBind CoreTickish
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 (CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
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 CoreTickish
_ 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 (Alt 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
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