{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CoreToStg.Prep
( CorePrepConfig (..)
, CorePrepPgmConfig (..)
, corePrepPgm
, corePrepExpr
, mkConvertNumLiteral
)
where
import GHC.Prelude
import GHC.Platform
import GHC.Driver.Flags
import GHC.Tc.Utils.Env
import GHC.Unit
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Core.Utils
import GHC.Core.Opt.Arity
import GHC.Core.Lint ( EndPassConfig(..), 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.Data.Pair
import GHC.Data.Graph.UnVar
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.Env
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Id.Make ( realWorldPrimId )
import GHC.Types.Basic
import GHC.Types.Name ( 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.Unique.Supply
import Data.List ( unfoldr )
import Data.Functor.Identity
import Control.Monad
type CpeArg = CoreExpr
type CpeApp = CoreExpr
type CpeBody = CoreExpr
type CpeRhs = CoreExpr
data CorePrepPgmConfig = CorePrepPgmConfig
{ CorePrepPgmConfig -> EndPassConfig
cpPgm_endPassConfig :: !EndPassConfig
, CorePrepPgmConfig -> Bool
cpPgm_generateDebugInfo :: !Bool
}
corePrepPgm :: Logger
-> CorePrepConfig
-> CorePrepPgmConfig
-> Module -> ModLocation -> CoreProgram -> [TyCon]
-> IO CoreProgram
corePrepPgm :: Logger
-> CorePrepConfig
-> CorePrepPgmConfig
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO CoreProgram
corePrepPgm Logger
logger CorePrepConfig
cp_cfg CorePrepPgmConfig
pgm_cfg
Module
this_mod ModLocation
mod_loc CoreProgram
binds [TyCon]
data_tycons =
Logger
-> SDoc -> (CoreProgram -> ()) -> IO CoreProgram -> IO CoreProgram
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CorePrep"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(\CoreProgram
a -> CoreProgram
a CoreProgram -> () -> ()
forall a b. [a] -> b -> b
`seqList` ()) (IO CoreProgram -> IO CoreProgram)
-> IO CoreProgram -> IO CoreProgram
forall a b. (a -> b) -> a -> b
$ do
UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
's'
let initialCorePrepEnv :: CorePrepEnv
initialCorePrepEnv = CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv CorePrepConfig
cp_cfg
let
implicit_binds :: CoreProgram
implicit_binds = Bool -> ModLocation -> [TyCon] -> CoreProgram
mkDataConWorkers
(CorePrepPgmConfig -> Bool
cpPgm_generateDebugInfo CorePrepPgmConfig
pgm_cfg)
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 a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> CoreProgram
deFloatTop (Floats
floats1 Floats -> Floats -> Floats
`appendFloats` Floats
floats2))
Logger -> EndPassConfig -> CoreProgram -> [CoreRule] -> IO ()
endPassIO Logger
logger (CorePrepPgmConfig -> EndPassConfig
cpPgm_endPassConfig CorePrepPgmConfig
pgm_cfg)
CoreProgram
binds_out []
CoreProgram -> IO CoreProgram
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreProgram
binds_out
corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr
corePrepExpr :: Logger -> CorePrepConfig -> CpeApp -> IO CpeApp
corePrepExpr Logger
logger CorePrepConfig
config CpeApp
expr = do
Logger -> SDoc -> (CpeApp -> ()) -> IO CpeApp -> IO CpeApp
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CorePrep [expr]") (\CpeApp
e -> CpeApp
e CpeApp -> () -> ()
forall a b. a -> b -> b
`seq` ()) (IO CpeApp -> IO CpeApp) -> IO CpeApp -> IO CpeApp
forall a b. (a -> b) -> a -> b
$ do
UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
's'
let initialCorePrepEnv :: CorePrepEnv
initialCorePrepEnv = CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv CorePrepConfig
config
let new_expr :: CpeApp
new_expr = UniqSupply -> UniqSM CpeApp -> CpeApp
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (CorePrepEnv -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
initialCorePrepEnv CpeApp
expr)
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_prep String
"CorePrep" DumpFormat
FormatCore (CpeApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeApp
new_expr)
CpeApp -> IO CpeApp
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CpeApp
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 a. a -> UniqSM a
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 a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats Floats -> Floats -> Floats
`appendFloats` Floats
floatss)
mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> [CoreBind]
mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> CoreProgram
mkDataConWorkers Bool
generate_debug_info ModLocation
mod_loc [TyCon]
data_tycons
= [ Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (Name -> CpeApp -> CpeApp
tick_it (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
data_con) (Id -> CpeApp
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 -> CpeApp -> CpeApp
tick_it Name
name
| Bool -> Bool
not Bool
generate_debug_info = CpeApp -> CpeApp
forall a. a -> a
id
| RealSrcSpan RealSrcSpan
span Maybe BufSpan
_ <- Name -> SrcSpan
nameSrcSpan Name
name = RealSrcSpan -> CpeApp -> CpeApp
tick RealSrcSpan
span
| Just String
file <- ModLocation -> Maybe String
ml_hs_file ModLocation
mod_loc = RealSrcSpan -> CpeApp -> CpeApp
tick (String -> RealSrcSpan
span1 String
file)
| Bool
otherwise = RealSrcSpan -> CpeApp -> CpeApp
tick (String -> RealSrcSpan
span1 String
"???")
where tick :: RealSrcSpan -> CpeApp -> CpeApp
tick RealSrcSpan
span = CoreTickish -> CpeApp -> CpeApp
forall b. CoreTickish -> Expr b -> Expr b
Tick (CoreTickish -> CpeApp -> CpeApp)
-> CoreTickish -> CpeApp -> CpeApp
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> String -> CoreTickish
forall (pass :: TickishPass).
RealSrcSpan -> String -> GenTickish pass
SourceNote RealSrcSpan
span (String -> CoreTickish) -> String -> CoreTickish
forall a b. (a -> b) -> a -> b
$
SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ 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 CpeApp
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 = (() :: Constraint) => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
bndr)
; (Floats
floats, CpeApp
rhs1) <- TopLevelFlag
-> RecFlag
-> Demand
-> Bool
-> CorePrepEnv
-> Id
-> CpeApp
-> UniqSM (Floats, CpeApp)
cpePair TopLevelFlag
top_lvl RecFlag
NonRecursive
Demand
dmd Bool
is_unlifted
CorePrepEnv
env Id
bndr1 CpeApp
rhs
; let triv_rhs :: Bool
triv_rhs = CpeApp -> Bool
exprIsTrivial CpeApp
rhs1
env2 :: CorePrepEnv
env2 | Bool
triv_rhs = CorePrepEnv -> Id -> CpeApp -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
env1 Id
bndr CpeApp
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 = CorePrepEnv -> Demand -> Bool -> Id -> CpeApp -> FloatingBind
mkFloat CorePrepEnv
env Demand
dmd Bool
is_unlifted Id
bndr1 CpeApp
rhs1
; (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall a. a -> UniqSM a
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, CpeApp
rhs1) <- CorePrepEnv -> Id -> CpeApp -> UniqSM (Id, CpeApp)
cpeJoinPair CorePrepEnv
env Id
bndr1 CpeApp
rhs
; (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall a. a -> UniqSM a
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 -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr2 CpeApp
rhs1)) }
cpeBind TopLevelFlag
top_lvl CorePrepEnv
env (Rec [(Id, CpeApp)]
pairs)
| Bool -> Bool
not (Id -> Bool
isJoinId ([Id] -> Id
forall a. HasCallStack => [a] -> a
head [Id]
bndrs))
= do { (CorePrepEnv
env, [Id]
bndrs1) <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
; let env' :: CorePrepEnv
env' = CorePrepEnv -> [Id] -> CorePrepEnv
enterRecGroupRHSs CorePrepEnv
env [Id]
bndrs1
; [(Floats, CpeApp)]
stuff <- (Id -> CpeApp -> UniqSM (Floats, CpeApp))
-> [Id] -> [CpeApp] -> UniqSM [(Floats, CpeApp)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TopLevelFlag
-> RecFlag
-> Demand
-> Bool
-> CorePrepEnv
-> Id
-> CpeApp
-> UniqSM (Floats, CpeApp)
cpePair TopLevelFlag
top_lvl RecFlag
Recursive Demand
topDmd Bool
False CorePrepEnv
env')
[Id]
bndrs1 [CpeApp]
rhss
; let ([Floats]
floats_s, [CpeApp]
rhss1) = [(Floats, CpeApp)] -> ([Floats], [CpeApp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Floats, CpeApp)]
stuff
all_pairs :: [(Id, CpeApp)]
all_pairs = (FloatingBind -> [(Id, CpeApp)] -> [(Id, CpeApp)])
-> [(Id, CpeApp)] -> OrdList FloatingBind -> [(Id, CpeApp)]
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> [(Id, CpeApp)] -> [(Id, CpeApp)]
add_float ([Id]
bndrs1 [Id] -> [CpeApp] -> [(Id, CpeApp)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CpeApp]
rhss1)
([Floats] -> OrdList FloatingBind
concatFloats [Floats]
floats_s)
; (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall a. a -> UniqSM a
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, CpeApp)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CpeApp)]
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
; let env' :: CorePrepEnv
env' = CorePrepEnv -> [Id] -> CorePrepEnv
enterRecGroupRHSs CorePrepEnv
env [Id]
bndrs1
; [(Id, CpeApp)]
pairs1 <- (Id -> CpeApp -> UniqSM (Id, CpeApp))
-> [Id] -> [CpeApp] -> UniqSM [(Id, CpeApp)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (CorePrepEnv -> Id -> CpeApp -> UniqSM (Id, CpeApp)
cpeJoinPair CorePrepEnv
env') [Id]
bndrs1 [CpeApp]
rhss
; let bndrs2 :: [Id]
bndrs2 = ((Id, CpeApp) -> Id) -> [(Id, CpeApp)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CpeApp) -> Id
forall a b. (a, b) -> a
fst [(Id, CpeApp)]
pairs1
; (CorePrepEnv, Floats, Maybe CoreBind)
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
forall a. a -> UniqSM a
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, CpeApp)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CpeApp)]
pairs1)) }
where
([Id]
bndrs, [CpeApp]
rhss) = [(Id, CpeApp)] -> ([Id], [CpeApp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CpeApp)]
pairs
add_float :: FloatingBind -> [(Id, CpeApp)] -> [(Id, CpeApp)]
add_float (FloatLet (NonRec Id
b CpeApp
r)) [(Id, CpeApp)]
prs2 = (Id
b,CpeApp
r) (Id, CpeApp) -> [(Id, CpeApp)] -> [(Id, CpeApp)]
forall a. a -> [a] -> [a]
: [(Id, CpeApp)]
prs2
add_float (FloatLet (Rec [(Id, CpeApp)]
prs1)) [(Id, CpeApp)]
prs2 = [(Id, CpeApp)]
prs1 [(Id, CpeApp)] -> [(Id, CpeApp)] -> [(Id, CpeApp)]
forall a. [a] -> [a] -> [a]
++ [(Id, CpeApp)]
prs2
add_float FloatingBind
b [(Id, CpeApp)]
_ = String -> SDoc -> [(Id, CpeApp)]
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
-> CpeApp
-> UniqSM (Floats, CpeApp)
cpePair TopLevelFlag
top_lvl RecFlag
is_rec Demand
dmd Bool
is_unlifted CorePrepEnv
env Id
bndr CpeApp
rhs
= Bool -> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Id -> Bool
isJoinId Id
bndr)) (UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp))
-> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a b. (a -> b) -> a -> b
$
do { (Floats
floats1, CpeApp
rhs1) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
rhs
; (Floats
floats2, CpeApp
rhs2) <- Floats -> CpeApp -> UniqSM (Floats, CpeApp)
float_from_rhs Floats
floats1 CpeApp
rhs1
; (Floats
floats3, CpeApp
rhs3)
<- if CpeApp -> Int
manifestArity CpeApp
rhs1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
arity
then (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats2, Int -> CpeApp -> CpeApp
cpeEtaExpand Int
arity CpeApp
rhs2)
else Bool
-> String
-> SDoc
-> UniqSM (Floats, CpeApp)
-> UniqSM (Floats, CpeApp)
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True String
"CorePrep: silly extra arguments:" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr) (UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp))
-> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a b. (a -> b) -> a -> b
$
(do { Id
v <- Type -> UniqSM Id
newVar (Id -> Type
idType Id
bndr)
; let float :: FloatingBind
float = CorePrepEnv -> Demand -> Bool -> Id -> CpeApp -> FloatingBind
mkFloat CorePrepEnv
env Demand
topDmd Bool
False Id
v CpeApp
rhs2
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( Floats -> FloatingBind -> Floats
addFloat Floats
floats2 FloatingBind
float
, Int -> CpeApp -> CpeApp
cpeEtaExpand Int
arity (Id -> CpeApp
forall b. Id -> Expr b
Var Id
v)) })
; let (Floats
floats4, CpeApp
rhs4) = Floats -> CpeApp -> (Floats, CpeApp)
wrapTicks Floats
floats3 CpeApp
rhs3
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats4, CpeApp
rhs4) }
where
arity :: Int
arity = Id -> Int
idArity Id
bndr
float_from_rhs :: Floats -> CpeApp -> UniqSM (Floats, CpeApp)
float_from_rhs Floats
floats CpeApp
rhs
| Floats -> Bool
isEmptyFloats Floats
floats = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeApp
rhs)
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl = Floats -> CpeApp -> UniqSM (Floats, CpeApp)
float_top Floats
floats CpeApp
rhs
| Bool
otherwise = Floats -> CpeApp -> UniqSM (Floats, CpeApp)
float_nested Floats
floats CpeApp
rhs
float_nested :: Floats -> CpeApp -> UniqSM (Floats, CpeApp)
float_nested Floats
floats CpeApp
rhs
| RecFlag -> Demand -> Bool -> Floats -> CpeApp -> Bool
wantFloatNested RecFlag
is_rec Demand
dmd Bool
is_unlifted Floats
floats CpeApp
rhs
= (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp
rhs)
| Bool
otherwise = Floats -> CpeApp -> UniqSM (Floats, CpeApp)
dontFloat Floats
floats CpeApp
rhs
float_top :: Floats -> CpeApp -> UniqSM (Floats, CpeApp)
float_top Floats
floats CpeApp
rhs
| Floats -> Bool
allLazyTop Floats
floats
= (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp
rhs)
| Just (Floats, CpeApp)
floats <- Floats -> CpeApp -> Maybe (Floats, CpeApp)
canFloat Floats
floats CpeApp
rhs
= (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats, CpeApp)
floats
| Bool
otherwise
= Floats -> CpeApp -> UniqSM (Floats, CpeApp)
dontFloat Floats
floats CpeApp
rhs
dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)
dontFloat :: Floats -> CpeApp -> UniqSM (Floats, CpeApp)
dontFloat Floats
floats1 CpeApp
rhs
= do { (Floats
floats2, CpeApp
body) <- CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody CpeApp
rhs
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Floats -> CpeApp -> CpeApp
wrapBinds Floats
floats1 (CpeApp -> CpeApp) -> CpeApp -> CpeApp
forall a b. (a -> b) -> a -> b
$
Floats -> CpeApp -> CpeApp
wrapBinds Floats
floats2 CpeApp
body) }
cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
-> UniqSM (JoinId, CpeRhs)
cpeJoinPair :: CorePrepEnv -> Id -> CpeApp -> UniqSM (Id, CpeApp)
cpeJoinPair CorePrepEnv
env Id
bndr CpeApp
rhs
= Bool -> UniqSM (Id, CpeApp) -> UniqSM (Id, CpeApp)
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isJoinId Id
bndr) (UniqSM (Id, CpeApp) -> UniqSM (Id, CpeApp))
-> UniqSM (Id, CpeApp) -> UniqSM (Id, CpeApp)
forall a b. (a -> b) -> a -> b
$
do { let Just Int
join_arity = Id -> Maybe Int
isJoinId_maybe Id
bndr
([Id]
bndrs, CpeApp
body) = Int -> CpeApp -> ([Id], CpeApp)
forall b. Int -> Expr b -> ([b], Expr b)
collectNBinders Int
join_arity CpeApp
rhs
; (CorePrepEnv
env', [Id]
bndrs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
; CpeApp
body' <- CorePrepEnv -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
env' CpeApp
body
; let rhs' :: CpeApp
rhs' = [Id] -> CpeApp -> CpeApp
mkCoreLams [Id]
bndrs' CpeApp
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, CpeApp) -> UniqSM (Id, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
bndr', CpeApp
rhs') }
cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeRhsE :: CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env (Type Type
ty)
= (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Type -> CpeApp
forall b. Type -> Expr b
Type (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty))
cpeRhsE CorePrepEnv
env (Coercion Coercion
co)
= (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, Coercion -> CpeApp
forall b. Coercion -> Expr b
Coercion (CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co))
cpeRhsE CorePrepEnv
env expr :: CpeApp
expr@(Lit (LitNumber LitNumType
nt Integer
i))
= case CorePrepConfig -> LitNumType -> Integer -> Maybe CpeApp
cp_convertNumLit (CorePrepEnv -> CorePrepConfig
cpe_config CorePrepEnv
env) LitNumType
nt Integer
i of
Maybe CpeApp
Nothing -> (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeApp
expr)
Just CpeApp
e -> CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
e
cpeRhsE CorePrepEnv
_env expr :: CpeApp
expr@(Lit {}) = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeApp
expr)
cpeRhsE CorePrepEnv
env expr :: CpeApp
expr@(Var {}) = CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeApp CorePrepEnv
env CpeApp
expr
cpeRhsE CorePrepEnv
env expr :: CpeApp
expr@(App {}) = CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeApp CorePrepEnv
env CpeApp
expr
cpeRhsE CorePrepEnv
env (Let CoreBind
bind CpeApp
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, CpeApp
body') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env' CpeApp
body
; let expr' :: CpeApp
expr' = case Maybe CoreBind
maybe_bind' of Just CoreBind
bind' -> CoreBind -> CpeApp -> CpeApp
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind' CpeApp
body'
Maybe CoreBind
Nothing -> CpeApp
body'
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
bind_floats Floats -> Floats -> Floats
`appendFloats` Floats
body_floats, CpeApp
expr') }
cpeRhsE CorePrepEnv
env (Tick CoreTickish
tickish CpeApp
expr)
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
tickish
= do { (Floats
floats, CpeApp
body) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
expr
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FloatingBind -> Floats
unitFloat (CoreTickish -> FloatingBind
FloatTick CoreTickish
tickish) Floats -> Floats -> Floats
`appendFloats` Floats
floats, CpeApp
body) }
| Bool
otherwise
= do { CpeApp
body <- CorePrepEnv -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
env CpeApp
expr
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
tickish' CpeApp
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 ((() :: Constraint) => CpeApp -> Id
CpeApp -> Id
getIdFromTrivialExpr (CpeApp -> Id) -> (Id -> CpeApp) -> Id -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CorePrepEnv -> Id -> CpeApp
lookupCorePrepEnv CorePrepEnv
env) [Id]
[XTickishId 'TickishPassCore]
fvs)
| Bool
otherwise
= CoreTickish
tickish
cpeRhsE CorePrepEnv
env (Cast CpeApp
expr Coercion
co)
= do { (Floats
floats, CpeApp
expr') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
expr
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp -> Coercion -> CpeApp
forall b. Expr b -> Coercion -> Expr b
Cast CpeApp
expr' (CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co)) }
cpeRhsE CorePrepEnv
env expr :: CpeApp
expr@(Lam {})
= do { let ([Id]
bndrs,CpeApp
body) = CpeApp -> ([Id], CpeApp)
forall b. Expr b -> ([b], Expr b)
collectBinders CpeApp
expr
; (CorePrepEnv
env', [Id]
bndrs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bndrs
; CpeApp
body' <- CorePrepEnv -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
env' CpeApp
body
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, [Id] -> CpeApp -> CpeApp
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bndrs' CpeApp
body') }
cpeRhsE CorePrepEnv
env (Case CpeApp
scrut Id
_ Type
ty [])
= do { (Floats
floats, CpeApp
scrut') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
scrut
; let ty' :: Type
ty' = CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty
scrut_ty' :: Type
scrut_ty' = (() :: Constraint) => CpeApp -> Type
CpeApp -> Type
exprType CpeApp
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, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp -> Coercion -> CpeApp
forall b. Expr b -> Coercion -> Expr b
Cast CpeApp
scrut' Coercion
co') }
cpeRhsE CorePrepEnv
env (Case CpeApp
scrut Id
bndr Type
_ [Alt Id]
alts)
| CpeApp -> Bool
isUnsafeEqualityProof CpeApp
scrut
, Id -> Bool
isDeadBinder Id
bndr
, [Alt AltCon
_ [Id
co_var] CpeApp
rhs] <- [Alt Id]
alts
, let Pair Type
ty1 Type
ty2 = (() :: Constraint) => 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 -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env' CpeApp
rhs
cpeRhsE CorePrepEnv
env (Case CpeApp
scrut Id
bndr Type
ty [Alt Id]
alts)
= do { (Floats
floats, CpeApp
scrut') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeBody CorePrepEnv
env CpeApp
scrut
; (CorePrepEnv
env', Id
bndr2) <- CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env Id
bndr
; let alts' :: [Alt Id]
alts'
| CorePrepConfig -> Bool
cp_catchNonexhaustiveCases (CorePrepConfig -> Bool) -> CorePrepConfig -> Bool
forall a b. (a -> b) -> a -> b
$ CorePrepEnv -> CorePrepConfig
cpe_config CorePrepEnv
env
, Bool -> Bool
not ([Alt Id] -> Bool
forall b. [Alt b] -> Bool
altsAreExhaustive [Alt Id]
alts)
= [Alt Id] -> Maybe CpeApp -> [Alt Id]
forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
addDefault [Alt Id]
alts (CpeApp -> Maybe CpeApp
forall a. a -> Maybe a
Just CpeApp
err)
| Bool
otherwise = [Alt Id]
alts
where err :: CpeApp
err = Type -> String -> CpeApp
mkImpossibleExpr Type
ty String
"cpeRhsE: missing case alternative"
; [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (CorePrepEnv -> Alt Id -> UniqSM (Alt Id)
sat_alt CorePrepEnv
env') [Alt Id]
alts'
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp -> Id -> Type -> [Alt Id] -> CpeApp
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeApp
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 CpeApp
rhs)
= do { (CorePrepEnv
env2, [Id]
bs') <- CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bs
; CpeApp
rhs' <- CorePrepEnv -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
env2 CpeApp
rhs
; Alt Id -> UniqSM (Alt Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [Id] -> CpeApp -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bs' CpeApp
rhs') }
cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
cpeBodyNF :: CorePrepEnv -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
env CpeApp
expr
= do { (Floats
floats, CpeApp
body) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeBody CorePrepEnv
env CpeApp
expr
; CpeApp -> UniqSM CpeApp
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> CpeApp -> CpeApp
wrapBinds Floats
floats CpeApp
body) }
cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
cpeBody :: CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeBody CorePrepEnv
env CpeApp
expr
= do { (Floats
floats1, CpeApp
rhs) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
expr
; (Floats
floats2, CpeApp
body) <- CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody CpeApp
rhs
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats1 Floats -> Floats -> Floats
`appendFloats` Floats
floats2, CpeApp
body) }
rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
rhsToBody :: CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody (Tick CoreTickish
t CpeApp
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, CpeApp
expr') <- CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody CpeApp
expr
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
t CpeApp
expr') }
rhsToBody (Cast CpeApp
e Coercion
co)
= do { (Floats
floats, CpeApp
e') <- CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody CpeApp
e
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp -> Coercion -> CpeApp
forall b. Expr b -> Coercion -> Expr b
Cast CpeApp
e' Coercion
co) }
rhsToBody expr :: CpeApp
expr@(Lam {})
| (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isTyVar [Id]
bndrs
= (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeApp
expr)
| Bool
otherwise
= do { let rhs :: CpeApp
rhs = Int -> CpeApp -> CpeApp
cpeEtaExpand (CpeApp -> Int
exprArity CpeApp
expr) CpeApp
expr
; Id
fn <- Type -> UniqSM Id
newVar ((() :: Constraint) => CpeApp -> Type
CpeApp -> Type
exprType CpeApp
rhs)
; let float :: FloatingBind
float = CoreBind -> FloatingBind
FloatLet (Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
fn CpeApp
rhs)
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FloatingBind -> Floats
unitFloat FloatingBind
float, Id -> CpeApp
forall b. Id -> Expr b
Var Id
fn) }
where
([Id]
bndrs,CpeApp
_) = CpeApp -> ([Id], CpeApp)
forall b. Expr b -> ([b], Expr b)
collectBinders CpeApp
expr
rhsToBody CpeApp
expr = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeApp
expr)
data ArgInfo = CpeApp CoreArg
| CpeCast Coercion
| CpeTick CoreTickish
instance Outputable ArgInfo where
ppr :: ArgInfo -> SDoc
ppr (CpeApp CpeApp
arg) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"app" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CpeApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeApp
arg
ppr (CpeCast Coercion
co) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cast" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
ppr (CpeTick CoreTickish
tick) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tick" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreTickish
tick
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeApp :: CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeApp CorePrepEnv
top_env CpeApp
expr
= do { let (CpeApp
terminal, [ArgInfo]
args) = CpeApp -> (CpeApp, [ArgInfo])
collect_args CpeApp
expr
; CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app CorePrepEnv
top_env CpeApp
terminal [ArgInfo]
args
}
where
collect_args :: CoreExpr -> (CoreExpr, [ArgInfo])
collect_args :: CpeApp -> (CpeApp, [ArgInfo])
collect_args CpeApp
e = CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
go CpeApp
e []
where
go :: CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
go (App CpeApp
fun CpeApp
arg) [ArgInfo]
as
= CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
go CpeApp
fun (CpeApp -> ArgInfo
CpeApp CpeApp
arg ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as)
go (Cast CpeApp
fun Coercion
co) [ArgInfo]
as
= CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
go CpeApp
fun (Coercion -> ArgInfo
CpeCast Coercion
co ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as)
go (Tick CoreTickish
tickish CpeApp
fun) [ArgInfo]
as
| Var Id
vh <- CpeApp
head
, Var Id
head' <- CorePrepEnv -> Id -> CpeApp
lookupCorePrepEnv CorePrepEnv
top_env Id
vh
, Id -> CoreTickish -> Bool
forall (pass :: TickishPass). Id -> GenTickish pass -> Bool
etaExpansionTick Id
head' CoreTickish
tickish
= (CpeApp
head,[ArgInfo]
as')
where
(CpeApp
head,[ArgInfo]
as') = CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
go CpeApp
fun (CoreTickish -> ArgInfo
CpeTick CoreTickish
tickish ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as)
go CpeApp
terminal [ArgInfo]
as = (CpeApp
terminal, [ArgInfo]
as)
cpe_app :: CorePrepEnv
-> CoreExpr
-> [ArgInfo]
-> UniqSM (Floats, CpeRhs)
cpe_app :: CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app CorePrepEnv
env (Var Id
f) (CpeApp Type{} : CpeApp CpeApp
arg : [ArgInfo]
args)
| 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 Bool -> Bool -> Bool
|| Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
noinlineConstraintIdKey
Bool -> Bool -> Bool
|| Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
nospecIdKey
= let (CpeApp
terminal, [ArgInfo]
args') = CpeApp -> (CpeApp, [ArgInfo])
collect_args CpeApp
arg
in CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app CorePrepEnv
env CpeApp
terminal ([ArgInfo]
args' [ArgInfo] -> [ArgInfo] -> [ArgInfo]
forall a. [a] -> [a] -> [a]
++ [ArgInfo]
args)
cpe_app CorePrepEnv
env (Var Id
f) (CpeApp _runtimeRep :: CpeApp
_runtimeRep@Type{} : CpeApp _type :: CpeApp
_type@Type{} : CpeApp CpeApp
arg : [ArgInfo]
rest)
| Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
runRWKey
, [ArgInfo] -> Bool
has_value_arg (CpeApp -> ArgInfo
CpeApp CpeApp
arg ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
rest)
= case CpeApp
arg of
Lam Id
s CpeApp
body -> CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app (CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env Id
s Id
realWorldPrimId) CpeApp
body [ArgInfo]
rest
CpeApp
_ -> CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app CorePrepEnv
env CpeApp
arg (CpeApp -> ArgInfo
CpeApp (Id -> CpeApp
forall b. Id -> Expr b
Var Id
realWorldPrimId) ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
rest)
where
has_value_arg :: [ArgInfo] -> Bool
has_value_arg [] = Bool
False
has_value_arg (CpeApp CpeApp
arg:[ArgInfo]
_rest)
| Bool -> Bool
not (CpeApp -> Bool
forall b. Expr b -> Bool
isTyCoArg CpeApp
arg) = Bool
True
has_value_arg (ArgInfo
_:[ArgInfo]
rest) = [ArgInfo] -> Bool
has_value_arg [ArgInfo]
rest
cpe_app CorePrepEnv
env (Var Id
v) [ArgInfo]
args
= do { Id
v1 <- Id -> UniqSM Id
fiddleCCall Id
v
; let e2 :: CpeApp
e2 = CorePrepEnv -> Id -> CpeApp
lookupCorePrepEnv CorePrepEnv
env Id
v1
hd :: Maybe Id
hd = CpeApp -> Maybe Id
getIdFromTrivialExpr_maybe CpeApp
e2
min_arity :: Maybe Int
min_arity = case Maybe Id
hd of
Just Id
v_hd -> if Id -> Bool
hasNoBinding Id
v_hd then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$! (Id -> Int
idArity Id
v_hd) else Maybe Int
forall a. Maybe a
Nothing
Maybe Id
Nothing -> Maybe Int
forall a. Maybe a
Nothing
; (CpeApp
app, Floats
floats, [CoreTickish]
unsat_ticks) <- CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> Maybe Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app CorePrepEnv
env [ArgInfo]
args CpeApp
e2 Floats
emptyFloats [Demand]
stricts Maybe Int
min_arity
; Maybe Id
-> CpeApp
-> Floats
-> [CoreTickish]
-> Int
-> UniqSM (Floats, CpeApp)
forall {a}.
Maybe Id
-> CpeApp -> a -> [CoreTickish] -> Int -> UniqSM (a, CpeApp)
mb_saturate Maybe Id
hd CpeApp
app Floats
floats [CoreTickish]
unsat_ticks Int
depth }
where
depth :: Int
depth = [ArgInfo] -> Int
val_args [ArgInfo]
args
stricts :: [Demand]
stricts = case Id -> DmdSig
idDmdSig Id
v of
DmdSig (DmdType DmdEnv
_ [Demand]
demands)
| [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 CpeApp
fun [] = CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
fun
cpe_app CorePrepEnv
env CpeApp
fun [ArgInfo]
args
= do { (Floats
fun_floats, CpeApp
fun') <- CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
cpeArg CorePrepEnv
env Demand
evalDmd CpeApp
fun
; (CpeApp
app, Floats
floats,[CoreTickish]
unsat_ticks) <- CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> Maybe Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app CorePrepEnv
env [ArgInfo]
args CpeApp
fun' Floats
fun_floats [] Maybe Int
forall a. Maybe a
Nothing
; Maybe Id
-> CpeApp
-> Floats
-> [CoreTickish]
-> Int
-> UniqSM (Floats, CpeApp)
forall {a}.
Maybe Id
-> CpeApp -> a -> [CoreTickish] -> Int -> UniqSM (a, CpeApp)
mb_saturate Maybe Id
forall a. Maybe a
Nothing CpeApp
app Floats
floats [CoreTickish]
unsat_ticks ([ArgInfo] -> Int
val_args [ArgInfo]
args) }
val_args :: [ArgInfo] -> Int
val_args :: [ArgInfo] -> Int
val_args [ArgInfo]
args = [ArgInfo] -> Int -> Int
forall {t}. Num t => [ArgInfo] -> t -> t
go [ArgInfo]
args Int
0
where
go :: [ArgInfo] -> t -> t
go [] !t
n = t
n
go (ArgInfo
info:[ArgInfo]
infos) t
n =
case ArgInfo
info of
CpeCast {} -> [ArgInfo] -> t -> t
go [ArgInfo]
infos t
n
CpeTick CoreTickish
tickish
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
tickish -> [ArgInfo] -> t -> t
go [ArgInfo]
infos t
n
| Bool
otherwise -> t
n
CpeApp CpeApp
e -> [ArgInfo] -> t -> t
go [ArgInfo]
infos t
n'
where
!n' :: t
n'
| CpeApp -> Bool
forall b. Expr b -> Bool
isTypeArg CpeApp
e = t
n
| Bool
otherwise = t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1
mb_saturate :: Maybe Id
-> CpeApp -> a -> [CoreTickish] -> Int -> UniqSM (a, CpeApp)
mb_saturate Maybe Id
head CpeApp
app a
floats [CoreTickish]
unsat_ticks Int
depth =
case Maybe Id
head of
Just Id
fn_id -> do { CpeApp
sat_app <- Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeApp
maybeSaturate Id
fn_id CpeApp
app Int
depth [CoreTickish]
unsat_ticks
; (a, CpeApp) -> UniqSM (a, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
floats, CpeApp
sat_app) }
Maybe Id
_other -> do { Bool -> UniqSM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([CoreTickish] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreTickish]
unsat_ticks)
; (a, CpeApp) -> UniqSM (a, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
floats, CpeApp
app) }
rebuild_app
:: CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> Maybe Arity
-> UniqSM (CpeApp
,Floats
,[CoreTickish]
)
rebuild_app :: CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> Maybe Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app CorePrepEnv
env [ArgInfo]
args CpeApp
app Floats
floats [Demand]
ss Maybe Int
req_depth =
CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
args CpeApp
app Floats
floats [Demand]
ss [] (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
req_depth)
rebuild_app'
:: CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' :: CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
_ [] CpeApp
app Floats
floats [Demand]
ss [CoreTickish]
rt_ticks !Int
_req_depth
= Bool
-> SDoc
-> ((CpeApp, Floats, [CoreTickish])
-> UniqSM (CpeApp, Floats, [CoreTickish]))
-> (CpeApp, Floats, [CoreTickish])
-> UniqSM (CpeApp, Floats, [CoreTickish])
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([Demand] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Demand]
ss) ([Demand] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Demand]
ss)
(CpeApp, Floats, [CoreTickish])
-> UniqSM (CpeApp, Floats, [CoreTickish])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CpeApp
app, Floats
floats, [CoreTickish]
rt_ticks)
rebuild_app' CorePrepEnv
env (ArgInfo
a : [ArgInfo]
as) CpeApp
fun' Floats
floats [Demand]
ss [CoreTickish]
rt_ticks Int
req_depth = case ArgInfo
a of
ArgInfo
_
| Bool -> Bool
not ([CoreTickish] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreTickish]
rt_ticks)
, Int
req_depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
->
let tick_fun :: CpeApp
tick_fun = (CoreTickish -> CpeApp -> CpeApp)
-> CpeApp -> [CoreTickish] -> CpeApp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CpeApp -> CpeApp
mkTick CpeApp
fun' [CoreTickish]
rt_ticks
in CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env (ArgInfo
a ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as) CpeApp
tick_fun Floats
floats [Demand]
ss [CoreTickish]
rt_ticks Int
req_depth
CpeApp (Type Type
arg_ty)
-> CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as (CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
App CpeApp
fun' (Type -> CpeApp
forall b. Type -> Expr b
Type Type
arg_ty')) Floats
floats [Demand]
ss [CoreTickish]
rt_ticks Int
req_depth
where
arg_ty' :: Type
arg_ty' = CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
arg_ty
CpeApp (Coercion Coercion
co)
-> CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as (CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
App CpeApp
fun' (Coercion -> CpeApp
forall b. Coercion -> Expr b
Coercion Coercion
co')) Floats
floats (Int -> [Demand] -> [Demand]
forall a. Int -> [a] -> [a]
drop Int
1 [Demand]
ss) [CoreTickish]
rt_ticks Int
req_depth
where
co' :: Coercion
co' = CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co
CpeApp CpeApp
arg -> do
let (Demand
ss1, [Demand]
ss_rest)
= case ([Demand]
ss, CpeApp -> Bool
isLazyExpr CpeApp
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, CpeApp
arg') <- CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
cpeArg CorePrepEnv
top_env Demand
ss1 CpeApp
arg
CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as (CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
App CpeApp
fun' CpeApp
arg') (Floats
fs Floats -> Floats -> Floats
`appendFloats` Floats
floats) [Demand]
ss_rest [CoreTickish]
rt_ticks (Int
req_depthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
CpeCast Coercion
co
-> CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as (CpeApp -> Coercion -> CpeApp
forall b. Expr b -> Coercion -> Expr b
Cast CpeApp
fun' Coercion
co') Floats
floats [Demand]
ss [CoreTickish]
rt_ticks Int
req_depth
where
co' :: Coercion
co' = CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co
CpeTick CoreTickish
tickish
| CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
tickish TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceRuntime
, Int
req_depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
-> Bool
-> UniqSM (CpeApp, Floats, [CoreTickish])
-> UniqSM (CpeApp, Floats, [CoreTickish])
forall a. HasCallStack => Bool -> a -> a
assert (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
isProfTick CoreTickish
tickish) (UniqSM (CpeApp, Floats, [CoreTickish])
-> UniqSM (CpeApp, Floats, [CoreTickish]))
-> UniqSM (CpeApp, Floats, [CoreTickish])
-> UniqSM (CpeApp, Floats, [CoreTickish])
forall a b. (a -> b) -> a -> b
$
CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as CpeApp
fun' Floats
floats [Demand]
ss (CoreTickish
tickishCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
rt_ticks) Int
req_depth
| Bool
otherwise
-> CorePrepEnv
-> [ArgInfo]
-> CpeApp
-> Floats
-> [Demand]
-> [CoreTickish]
-> Int
-> UniqSM (CpeApp, Floats, [CoreTickish])
rebuild_app' CorePrepEnv
env [ArgInfo]
as CpeApp
fun' (Floats -> FloatingBind -> Floats
addFloat Floats
floats (CoreTickish -> FloatingBind
FloatTick CoreTickish
tickish)) [Demand]
ss [CoreTickish]
rt_ticks Int
req_depth
isLazyExpr :: CoreExpr -> Bool
isLazyExpr :: CpeApp -> Bool
isLazyExpr (Cast CpeApp
e Coercion
_) = CpeApp -> Bool
isLazyExpr CpeApp
e
isLazyExpr (Tick CoreTickish
_ CpeApp
e) = CpeApp -> Bool
isLazyExpr CpeApp
e
isLazyExpr (Var Id
f `App` CpeApp
_ `App` CpeApp
_) = Id
f Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
lazyIdKey
isLazyExpr CpeApp
_ = Bool
False
okCpeArg :: CoreExpr -> Bool
okCpeArg :: CpeApp -> Bool
okCpeArg (Lit Literal
_) = Bool
False
okCpeArg CpeApp
expr = Bool -> Bool
not (CpeApp -> Bool
exprIsTrivial CpeApp
expr)
cpeArg :: CorePrepEnv -> Demand
-> CoreArg -> UniqSM (Floats, CpeArg)
cpeArg :: CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
cpeArg CorePrepEnv
env Demand
dmd CpeApp
arg
= do { (Floats
floats1, CpeApp
arg1) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
arg
; let arg_ty :: Type
arg_ty = (() :: Constraint) => CpeApp -> Type
CpeApp -> Type
exprType CpeApp
arg1
is_unlifted :: Bool
is_unlifted = (() :: Constraint) => Type -> Bool
Type -> Bool
isUnliftedType Type
arg_ty
want_float :: Floats -> CpeApp -> Bool
want_float = RecFlag -> Demand -> Bool -> Floats -> CpeApp -> Bool
wantFloatNested RecFlag
NonRecursive Demand
dmd Bool
is_unlifted
; (Floats
floats2, CpeApp
arg2) <- if Floats -> CpeApp -> Bool
want_float Floats
floats1 CpeApp
arg1
then (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats1, CpeApp
arg1)
else Floats -> CpeApp -> UniqSM (Floats, CpeApp)
dontFloat Floats
floats1 CpeApp
arg1
; if CpeApp -> Bool
okCpeArg CpeApp
arg2
then do { Id
v <- Type -> UniqSM Id
newVar Type
arg_ty
; let arg3 :: CpeApp
arg3 = Int -> CpeApp -> CpeApp
cpeEtaExpand (CpeApp -> Int
exprArity CpeApp
arg2) CpeApp
arg2
arg_float :: FloatingBind
arg_float = CorePrepEnv -> Demand -> Bool -> Id -> CpeApp -> FloatingBind
mkFloat CorePrepEnv
env Demand
dmd Bool
is_unlifted Id
v CpeApp
arg3
; (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> FloatingBind -> Floats
addFloat Floats
floats2 FloatingBind
arg_float, Id -> CpeApp
forall b. Id -> Expr b
varToCoreExpr Id
v) }
else (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats2, CpeApp
arg2)
}
maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs
maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeApp
maybeSaturate Id
fn CpeApp
expr Int
n_args [CoreTickish]
unsat_ticks
| Id -> Bool
hasNoBinding Id
fn
= CpeApp -> UniqSM CpeApp
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CpeApp -> UniqSM CpeApp) -> CpeApp -> UniqSM CpeApp
forall a b. (a -> b) -> a -> b
$ (CpeApp -> CpeApp) -> CpeApp -> CpeApp
wrapLamBody (\CpeApp
body -> (CoreTickish -> CpeApp -> CpeApp)
-> CpeApp -> [CoreTickish] -> CpeApp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CpeApp -> CpeApp
mkTick CpeApp
body [CoreTickish]
unsat_ticks) CpeApp
sat_expr
| Int
mark_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
, Bool -> Bool
not Bool
applied_marks
= Bool -> SDoc -> UniqSM CpeApp -> UniqSM CpeApp
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr
( Bool -> Bool
not (Id -> Bool
isJoinId Id
fn))
( Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"expr:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CpeApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeApp
expr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"n_args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n_args SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"marks:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe [CbvMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
fn) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"join_arity" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Maybe Int
isJoinId_maybe Id
fn) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fn_arity" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
fn_arity
) (UniqSM CpeApp -> UniqSM CpeApp) -> UniqSM CpeApp -> UniqSM CpeApp
forall a b. (a -> b) -> a -> b
$
CpeApp -> UniqSM CpeApp
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return CpeApp
sat_expr
| Bool
otherwise
= Bool -> UniqSM CpeApp -> UniqSM CpeApp
forall a. HasCallStack => Bool -> a -> a
assert ([CoreTickish] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreTickish]
unsat_ticks) (UniqSM CpeApp -> UniqSM CpeApp) -> UniqSM CpeApp -> UniqSM CpeApp
forall a b. (a -> b) -> a -> b
$
CpeApp -> UniqSM CpeApp
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return CpeApp
expr
where
mark_arity :: Int
mark_arity = Id -> Int
idCbvMarkArity Id
fn
fn_arity :: Int
fn_arity = Id -> Int
idArity Id
fn
excess_arity :: Int
excess_arity = (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
fn_arity Int
mark_arity) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_args
sat_expr :: CpeApp
sat_expr = Int -> CpeApp -> CpeApp
cpeEtaExpand Int
excess_arity CpeApp
expr
applied_marks :: Bool
applied_marks = Int
n_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= ([CbvMark] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([CbvMark] -> Int)
-> (Maybe [CbvMark] -> [CbvMark]) -> Maybe [CbvMark] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CbvMark -> Bool) -> [CbvMark] -> [CbvMark]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (CbvMark -> Bool) -> CbvMark -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CbvMark -> Bool
isMarkedCbv) ([CbvMark] -> [CbvMark])
-> (Maybe [CbvMark] -> [CbvMark]) -> Maybe [CbvMark] -> [CbvMark]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CbvMark] -> [CbvMark]
forall a. [a] -> [a]
reverse ([CbvMark] -> [CbvMark])
-> (Maybe [CbvMark] -> [CbvMark]) -> Maybe [CbvMark] -> [CbvMark]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe [CbvMark] -> [CbvMark]
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"maybeSaturate" (Maybe [CbvMark] -> Int) -> Maybe [CbvMark] -> Int
forall a b. (a -> b) -> a -> b
$ (Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
fn))
cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
cpeEtaExpand :: Int -> CpeApp -> CpeApp
cpeEtaExpand Int
arity CpeApp
expr
| Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = CpeApp
expr
| Bool
otherwise = Int -> CpeApp -> CpeApp
etaExpand Int
arity CpeApp
expr
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 CpeApp
r Id
b AltCon
k [Id]
bs Bool
ok) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"case" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
ok) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CpeApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeApp
r
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"of"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"@"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> case [Id]
bs of
[] -> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
k
[Id]
_ -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
k SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [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
forall doc. IsLine doc => String -> doc
text String
"Floats" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (OkToSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr OkToSpec
flag) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsLine doc => String -> doc
text String
"OkToSpec"
ppr OkToSpec
IfUnboxedOk = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"IfUnboxedOk"
ppr OkToSpec
NotOkToSpec = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NotOkToSpec"
data OkToSpec
= OkToSpec
| IfUnboxedOk
| NotOkToSpec
mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind
mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeApp -> FloatingBind
mkFloat CorePrepEnv
env Demand
dmd Bool
is_unlifted Id
bndr CpeApp
rhs
| Bool
is_strict Bool -> Bool -> Bool
|| Bool
ok_for_spec
, Bool -> Bool
not Bool
is_hnf = CpeApp -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase CpeApp
rhs Id
bndr AltCon
DEFAULT [] Bool
ok_for_spec
| Bool
is_unlifted = CpeApp -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase CpeApp
rhs Id
bndr AltCon
DEFAULT [] Bool
True
| Bool
is_hnf = CoreBind -> FloatingBind
FloatLet (Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr CpeApp
rhs)
| Bool
otherwise = CoreBind -> FloatingBind
FloatLet (Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec (Id -> Demand -> Id
setIdDemandInfo Id
bndr Demand
dmd) CpeApp
rhs)
where
is_hnf :: Bool
is_hnf = CpeApp -> Bool
exprIsHNF CpeApp
rhs
is_strict :: Bool
is_strict = Demand -> Bool
isStrUsedDmd Demand
dmd
ok_for_spec :: Bool
ok_for_spec = (Id -> Bool) -> CpeApp -> Bool
exprOkForSpecEval (Bool -> Bool
not (Bool -> Bool) -> (Id -> Bool) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Bool
is_rec_call) CpeApp
rhs
is_rec_call :: Id -> Bool
is_rec_call = (Id -> UnVarSet -> Bool
`elemUnVarSet` CorePrepEnv -> UnVarSet
cpe_rec_ids CorePrepEnv
env)
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 -> CpeApp -> CpeApp
wrapBinds (Floats OkToSpec
_ OrdList FloatingBind
binds) CpeApp
body
= (FloatingBind -> CpeApp -> CpeApp)
-> CpeApp -> OrdList FloatingBind -> CpeApp
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> CpeApp -> CpeApp
mk_bind CpeApp
body OrdList FloatingBind
binds
where
mk_bind :: FloatingBind -> CpeApp -> CpeApp
mk_bind (FloatCase CpeApp
rhs Id
bndr AltCon
con [Id]
bs Bool
_) CpeApp
body = CpeApp -> Id -> Type -> [Alt Id] -> CpeApp
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeApp
rhs Id
bndr ((() :: Constraint) => CpeApp -> Type
CpeApp -> Type
exprType CpeApp
body) [AltCon -> [Id] -> CpeApp -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bs CpeApp
body]
mk_bind (FloatLet CoreBind
bind) CpeApp
body = CoreBind -> CpeApp -> CpeApp
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind CpeApp
body
mk_bind (FloatTick CoreTickish
tickish) CpeApp
body = CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
tickish CpeApp
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 CpeApp
_ 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 a b. (a -> b -> b) -> b -> [a] -> b
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 CpeApp
body Id
var AltCon
_ [Id]
_ Bool
_) CoreProgram
bs = CoreBind -> CoreBind
get_bind (Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
var CpeApp
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 CpeApp
e) = Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
x (CpeApp -> CpeApp
occurAnalyseExpr CpeApp
e)
get_bind (Rec [(Id, CpeApp)]
xes) = [(Id, CpeApp)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id
x, CpeApp -> CpeApp
occurAnalyseExpr CpeApp
e) | (Id
x, CpeApp
e) <- [(Id, CpeApp)]
xes]
canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
canFloat :: Floats -> CpeApp -> Maybe (Floats, CpeApp)
canFloat (Floats OkToSpec
ok_to_spec OrdList FloatingBind
fs) CpeApp
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, CpeApp) -> Maybe (Floats, CpeApp)
forall a. a -> Maybe a
Just (OkToSpec -> OrdList FloatingBind -> Floats
Floats OkToSpec
OkToSpec OrdList FloatingBind
fs', CpeApp
rhs)
| Bool
otherwise
= Maybe (Floats, CpeApp)
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 -> CpeApp -> Bool
wantFloatNested RecFlag
is_rec Demand
dmd Bool
is_unlifted Floats
floats CpeApp
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
&& CpeApp -> Bool
exprIsHNF CpeApp
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 CorePrepConfig = CorePrepConfig
{ CorePrepConfig -> Bool
cp_catchNonexhaustiveCases :: !Bool
, CorePrepConfig -> LitNumType -> Integer -> Maybe CpeApp
cp_convertNumLit :: !(LitNumType -> Integer -> Maybe CoreExpr)
}
data CorePrepEnv
= CPE { CorePrepEnv -> CorePrepConfig
cpe_config :: !CorePrepConfig
, CorePrepEnv -> IdEnv CpeApp
cpe_env :: IdEnv CoreExpr
, CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env :: Maybe CpeTyCoEnv
, CorePrepEnv -> UnVarSet
cpe_rec_ids :: UnVarSet
}
mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv CorePrepConfig
cfg = CPE
{ cpe_config :: CorePrepConfig
cpe_config = CorePrepConfig
cfg
, cpe_env :: IdEnv CpeApp
cpe_env = IdEnv CpeApp
forall a. VarEnv a
emptyVarEnv
, cpe_tyco_env :: Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
forall a. Maybe a
Nothing
, cpe_rec_ids :: UnVarSet
cpe_rec_ids = UnVarSet
emptyUnVarSet
}
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
cpe Id
id Id
id'
= CorePrepEnv
cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }
extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CpeApp -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
cpe Id
id CpeApp
expr
= CorePrepEnv
cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }
extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
extendCorePrepEnvList :: CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
extendCorePrepEnvList CorePrepEnv
cpe [(Id, Id)]
prs
= CorePrepEnv
cpe { cpe_env = extendVarEnvList (cpe_env cpe)
(map (\(Id
id, Id
id') -> (Id
id, Id -> CpeApp
forall b. Id -> Expr b
Var Id
id')) prs) }
lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
lookupCorePrepEnv :: CorePrepEnv -> Id -> CpeApp
lookupCorePrepEnv CorePrepEnv
cpe Id
id
= case IdEnv CpeApp -> Id -> Maybe CpeApp
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (CorePrepEnv -> IdEnv CpeApp
cpe_env CorePrepEnv
cpe) Id
id of
Maybe CpeApp
Nothing -> Id -> CpeApp
forall b. Id -> Expr b
Var Id
id
Just CpeApp
exp -> CpeApp
exp
enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv
enterRecGroupRHSs :: CorePrepEnv -> [Id] -> CorePrepEnv
enterRecGroupRHSs CorePrepEnv
env [Id]
grp
= CorePrepEnv
env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) }
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 = Just (extend_tce_cv tce cv 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
{ tcm_tyvar :: CpeTyCoEnv -> Id -> Identity Type
tcm_tyvar = \CpeTyCoEnv
env Id
tv -> Type -> Identity Type
forall a. a -> Identity a
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 a. a -> Identity a
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 -> ForAllTyFlag -> Identity (CpeTyCoEnv, Id)
tcm_tycobinder = \CpeTyCoEnv
env Id
tcv ForAllTyFlag
_vis -> if Id -> Bool
isTyVar Id
tcv
then (CpeTyCoEnv, Id) -> Identity (CpeTyCoEnv, Id)
forall a. a -> Identity a
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 a. a -> Identity a
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 a. a -> Identity a
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 = Just 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 = Just 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 :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t 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 a. a -> UniqSM a
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 a. a -> UniqSM a
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
trimUnfolding (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 a. a -> UniqSM a
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 a. a -> UniqSM a
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 a. a -> UniqSM a
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 a. a -> UniqSM a
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
forall a b. a -> b -> b
`seq` FastString -> Type -> Type -> UniqSM Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalOrCoVarM (String -> FastString
fsLit String
"sat") Type
ManyTy Type
ty
wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
wrapTicks :: Floats -> CpeApp -> (Floats, CpeApp)
wrapTicks (Floats OkToSpec
flag OrdList FloatingBind
floats0) CpeApp
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 -> CpeApp -> CpeApp)
-> CpeApp -> [CoreTickish] -> CpeApp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CpeApp -> CpeApp
mkTick CpeApp
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 a b. (a -> b -> b) -> b -> [a] -> b
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 CpeApp
r Id
b AltCon
con [Id]
bs Bool
ok) = CpeApp -> Id -> AltCon -> [Id] -> Bool -> FloatingBind
FloatCase (CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
t CpeApp
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 CpeApp
rhs) = Id -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
binder (CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
t CpeApp
rhs)
wrapBind CoreTickish
t (Rec [(Id, CpeApp)]
pairs) = [(Id, CpeApp)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ((CpeApp -> CpeApp) -> [(Id, CpeApp)] -> [(Id, CpeApp)]
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a, b) -> f (a, c)
mapSnd (CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
t) [(Id, CpeApp)]
pairs)
mkConvertNumLiteral
:: Platform
-> HomeUnit
-> (Name -> IO TyThing)
-> IO (LitNumType -> Integer -> Maybe CoreExpr)
mkConvertNumLiteral :: Platform
-> HomeUnit
-> (Name -> IO TyThing)
-> IO (LitNumType -> Integer -> Maybe CpeApp)
mkConvertNumLiteral Platform
platform HomeUnit
home_unit Name -> IO TyThing
lookup_global = do
let
guardBignum :: IO Id -> IO Id
guardBignum IO Id
act
| HomeUnit -> UnitId -> Bool
isHomeUnitInstanceOf HomeUnit
home_unit UnitId
primUnitId
= Id -> IO Id
forall a. a -> IO a
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. HasCallStack => 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 a. a -> IO a
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. HasCallStack => 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 ((() :: Constraint) => TyThing -> Id
TyThing -> Id
tyThingId (TyThing -> Id) -> IO TyThing -> IO Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IO TyThing
lookup_global Name
n)
Id
bignatFromWordListId <- Name -> IO Id
lookupBignumId Name
bignatFromWordListName
let
convertNumLit :: LitNumType -> Integer -> Maybe CpeApp
convertNumLit LitNumType
nt Integer
i = case LitNumType
nt of
LitNumType
LitNumBigNat -> CpeApp -> Maybe CpeApp
forall a. a -> Maybe a
Just (Integer -> CpeApp
convertBignatPrim Integer
i)
LitNumType
_ -> Maybe CpeApp
forall a. Maybe a
Nothing
convertBignatPrim :: Integer -> CpeApp
convertBignatPrim Integer
i =
let
words :: CpeApp
words = Type -> [CpeApp] -> CpeApp
mkListExpr Type
wordTy ([CpeApp] -> [CpeApp]
forall a. [a] -> [a]
reverse ((Integer -> Maybe (CpeApp, Integer)) -> Integer -> [CpeApp]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr Integer -> Maybe (CpeApp, Integer)
f Integer
i))
where
f :: Integer -> Maybe (CpeApp, Integer)
f Integer
0 = Maybe (CpeApp, 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 (CpeApp, Integer) -> Maybe (CpeApp, Integer)
forall a. a -> Maybe a
Just (DataCon -> [CpeApp] -> CpeApp
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
wordDataCon [Literal -> CpeApp
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitWord Platform
platform Integer
low)], Integer
high)
bits :: Int
bits = Platform -> Int
platformWordSizeInBits Platform
platform
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 CpeApp -> [CpeApp] -> CpeApp
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CpeApp
forall b. Id -> Expr b
Var Id
bignatFromWordListId) [CpeApp
words]
(LitNumType -> Integer -> Maybe CpeApp)
-> IO (LitNumType -> Integer -> Maybe CpeApp)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LitNumType -> Integer -> Maybe CpeApp
convertNumLit