{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CoreToStg.Prep
( CorePrepConfig (..)
, CorePrepPgmConfig (..)
, corePrepPgm
, corePrepExpr
)
where
import GHC.Prelude
import GHC.Platform
import GHC.Driver.Flags
import GHC.Unit
import GHC.Builtin.Names
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Core.Utils
import GHC.Core.Opt.Arity
import GHC.Core.Lint ( EndPassConfig(..), endPassIO )
import GHC.Core
import GHC.Core.Subst
import GHC.Core.Make hiding( FloatBind(..) )
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Opt.OccurAnal
import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.FastString
import GHC.Data.Graph.UnVar
import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Utils.Monad ( mapAccumLM )
import GHC.Utils.Logger
import GHC.Types.Demand
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Id.Make ( realWorldPrimId )
import GHC.Types.Basic
import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName )
import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
import GHC.Types.Literal
import GHC.Types.Tickish
import GHC.Types.Unique.Supply
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BB
import Data.ByteString.Builder.Prim
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
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
's'
let initialCorePrepEnv = CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv CorePrepConfig
cp_cfg
let
implicit_binds = Bool -> ModLocation -> [TyCon] -> CoreProgram
mkDataConWorkers
(CorePrepPgmConfig -> Bool
cpPgm_generateDebugInfo CorePrepPgmConfig
pgm_cfg)
ModLocation
mod_loc [TyCon]
data_tycons
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
floats1 <- CorePrepEnv -> CoreProgram -> UniqSM Floats
corePrepTopBinds CorePrepEnv
initialCorePrepEnv CoreProgram
binds
floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
return (deFloatTop (floats1 `zipFloats` floats2))
endPassIO logger (cpPgm_endPassConfig pgm_cfg)
binds_out []
return 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
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
's'
let initialCorePrepEnv = CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv CorePrepConfig
config
let new_expr = UniqSupply -> UniqSM CpeApp -> CpeApp
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (CorePrepEnv -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
initialCorePrepEnv CpeApp
expr)
putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)
return 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 (env', floats, maybe_new_bind)
<- TopLevelFlag
-> CorePrepEnv
-> CoreBind
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
cpeBind TopLevelFlag
TopLevel CorePrepEnv
env CoreBind
bind
massert (isNothing maybe_new_bind)
floatss <- go env' binds
return (floats `zipFloats` floatss)
mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> [CoreBind]
mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> CoreProgram
mkDataConWorkers Bool
generate_debug_info ModLocation
mod_loc [TyCon]
data_tycons
= [ InVar -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec InVar
id (Name -> CpeApp -> CpeApp
tick_it (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
data_con) (InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
id))
| TyCon
tycon <- [TyCon]
data_tycons,
DataCon
data_con <- TyCon -> [DataCon]
tyConDataCons TyCon
tycon,
let id :: InVar
id = DataCon -> InVar
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 -> LexicalFastString -> CoreTickish
forall (pass :: TickishPass).
RealSrcSpan -> LexicalFastString -> GenTickish pass
SourceNote RealSrcSpan
span (LexicalFastString -> CoreTickish)
-> LexicalFastString -> CoreTickish
forall a b. (a -> b) -> a -> b
$
FastString -> LexicalFastString
LexicalFastString (FastString -> LexicalFastString)
-> FastString -> LexicalFastString
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String -> FastString) -> String -> FastString
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 InVar
bndr CpeApp
rhs)
| Bool -> Bool
not (InVar -> Bool
isJoinId InVar
bndr)
= do { (env1, bndr1) <- CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
cpCloneBndr CorePrepEnv
env InVar
bndr
; let dmd = InVar -> Demand
idDemandInfo InVar
bndr
lev = HasDebugCallStack => Type -> Levity
Type -> Levity
typeLevity (InVar -> Type
idType InVar
bndr)
; (floats, rhs1) <- cpePair top_lvl NonRecursive
dmd lev env bndr1 rhs
; let triv_rhs = CpeApp -> Bool
exprIsTrivial CpeApp
rhs1
env2 | Bool
triv_rhs = CorePrepEnv -> InVar -> CpeApp -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
env1 InVar
bndr CpeApp
rhs1
| Bool
otherwise = CorePrepEnv
env1
floats1 | Bool
triv_rhs, Name -> Bool
isInternalName (InVar -> Name
idName InVar
bndr)
= Floats
floats
| Bool
otherwise
= Floats -> FloatingBind -> Floats
snocFloat Floats
floats FloatingBind
new_float
(new_float, _bndr2) = mkNonRecFloat env lev bndr1 rhs1
; return (env2, floats1, 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 { (_, bndr1) <- CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
cpCloneBndr CorePrepEnv
env InVar
bndr
; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
; return (extendCorePrepEnv env bndr bndr2,
emptyFloats,
Just (NonRec bndr2 rhs1)) }
cpeBind TopLevelFlag
top_lvl CorePrepEnv
env (Rec [(InVar, CpeApp)]
pairs)
| Bool -> Bool
not (InVar -> Bool
isJoinId ([InVar] -> InVar
forall a. HasCallStack => [a] -> a
head [InVar]
bndrs))
= do { (env, bndrs1) <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
cpCloneBndrs CorePrepEnv
env [InVar]
bndrs
; let env' = CorePrepEnv -> [InVar] -> CorePrepEnv
enterRecGroupRHSs CorePrepEnv
env [InVar]
bndrs1
; stuff <- zipWithM (cpePair top_lvl Recursive topDmd Lifted env')
bndrs1 rhss
; let (zipManyFloats -> floats, rhss1) = unzip stuff
is_lit (Float (NonRec InVar
_ CpeApp
rhs) BindInfo
CaseBound FloatInfo
TopLvlFloatable) = CpeApp -> Bool
exprIsTickedString CpeApp
rhs
is_lit FloatingBind
_ = Bool
False
(string_floats, top) = partitionOL is_lit (fs_binds floats)
floats' = Floats
floats { fs_binds = top }
all_pairs = (FloatingBind -> [(InVar, CpeApp)] -> [(InVar, CpeApp)])
-> [(InVar, CpeApp)] -> OrdList FloatingBind -> [(InVar, CpeApp)]
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> [(InVar, CpeApp)] -> [(InVar, CpeApp)]
add_float ([InVar]
bndrs1 [InVar] -> [CpeApp] -> [(InVar, CpeApp)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CpeApp]
rhss1) (Floats -> OrdList FloatingBind
getFloats Floats
floats')
; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),
snocFloat (emptyFloats { fs_binds = string_floats })
(Float (Rec all_pairs) LetBound TopLvlFloatable),
Nothing) }
| Bool
otherwise
= do { (env, bndrs1) <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
cpCloneBndrs CorePrepEnv
env [InVar]
bndrs
; let env' = CorePrepEnv -> [InVar] -> CorePrepEnv
enterRecGroupRHSs CorePrepEnv
env [InVar]
bndrs1
; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
; let bndrs2 = ((InVar, CpeApp) -> InVar) -> [(InVar, CpeApp)] -> [InVar]
forall a b. (a -> b) -> [a] -> [b]
map (InVar, CpeApp) -> InVar
forall a b. (a, b) -> a
fst [(InVar, CpeApp)]
pairs1
; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
emptyFloats,
Just (Rec pairs1)) }
where
([InVar]
bndrs, [CpeApp]
rhss) = [(InVar, CpeApp)] -> ([InVar], [CpeApp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(InVar, CpeApp)]
pairs
add_float :: FloatingBind -> [(InVar, CpeApp)] -> [(InVar, CpeApp)]
add_float (Float CoreBind
bind BindInfo
bound FloatInfo
_) [(InVar, CpeApp)]
prs2
| BindInfo
bound BindInfo -> BindInfo -> Bool
forall a. Eq a => a -> a -> Bool
/= BindInfo
CaseBound
Bool -> Bool -> Bool
|| (InVar -> Bool) -> [InVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (InVar -> Bool) -> InVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Type -> Bool) -> (InVar -> Type) -> InVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InVar -> Type
idType) (CoreBind -> [InVar]
forall b. Bind b -> [b]
bindersOf CoreBind
bind)
= case CoreBind
bind of
NonRec InVar
x CpeApp
e -> (InVar
x,CpeApp
e) (InVar, CpeApp) -> [(InVar, CpeApp)] -> [(InVar, CpeApp)]
forall a. a -> [a] -> [a]
: [(InVar, CpeApp)]
prs2
Rec [(InVar, CpeApp)]
prs1 -> [(InVar, CpeApp)]
prs1 [(InVar, CpeApp)] -> [(InVar, CpeApp)] -> [(InVar, CpeApp)]
forall a. [a] -> [a] -> [a]
++ [(InVar, CpeApp)]
prs2
add_float FloatingBind
f [(InVar, CpeApp)]
_ = String -> SDoc -> [(InVar, CpeApp)]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cpeBind" (FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
f)
cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity
-> CorePrepEnv -> OutId -> CoreExpr
-> UniqSM (Floats, CpeRhs)
cpePair :: TopLevelFlag
-> RecFlag
-> Demand
-> Levity
-> CorePrepEnv
-> InVar
-> CpeApp
-> UniqSM (Floats, CpeApp)
cpePair TopLevelFlag
top_lvl RecFlag
is_rec Demand
dmd Levity
lev CorePrepEnv
env InVar
bndr CpeApp
rhs
= Bool -> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (InVar -> Bool
isJoinId InVar
bndr)) (UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp))
-> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a b. (a -> b) -> a -> b
$
do { (floats1, rhs1) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
rhs
; let dec = Floats -> CpeApp -> FloatDecision
want_float_from_rhs Floats
floats1 CpeApp
rhs1
; (floats2, rhs2) <- executeFloatDecision dec floats1 rhs1
; (floats3, rhs3)
<- if manifestArity rhs1 <= arity
then return (floats2, cpeEtaExpand arity rhs2)
else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
(do { v <- newVar (idType bndr)
; let (float, v') = mkNonRecFloat env Lifted v rhs2
; return ( snocFloat floats2 float
, cpeEtaExpand arity (Var v')) })
; let (floats4, rhs4) = wrapTicks floats3 rhs3
; return (floats4, rhs4) }
where
arity :: Int
arity = InVar -> Int
idArity InVar
bndr
want_float_from_rhs :: Floats -> CpeApp -> FloatDecision
want_float_from_rhs Floats
floats CpeApp
rhs
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl = Floats -> FloatDecision
wantFloatTop Floats
floats
| Bool
otherwise = RecFlag -> Demand -> Levity -> Floats -> CpeApp -> FloatDecision
wantFloatLocal RecFlag
is_rec Demand
dmd Levity
lev Floats
floats CpeApp
rhs
cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
-> UniqSM (JoinId, CpeRhs)
cpeJoinPair :: CorePrepEnv -> InVar -> CpeApp -> UniqSM (InVar, CpeApp)
cpeJoinPair CorePrepEnv
env InVar
bndr CpeApp
rhs
= Bool -> UniqSM (InVar, CpeApp) -> UniqSM (InVar, CpeApp)
forall a. HasCallStack => Bool -> a -> a
assert (InVar -> Bool
isJoinId InVar
bndr) (UniqSM (InVar, CpeApp) -> UniqSM (InVar, CpeApp))
-> UniqSM (InVar, CpeApp) -> UniqSM (InVar, CpeApp)
forall a b. (a -> b) -> a -> b
$
do { let JoinPoint Int
join_arity = InVar -> JoinPointHood
idJoinPointHood InVar
bndr
([InVar]
bndrs, CpeApp
body) = Int -> CpeApp -> ([InVar], CpeApp)
forall b. Int -> Expr b -> ([b], Expr b)
collectNBinders Int
join_arity CpeApp
rhs
; (env', bndrs') <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
cpCloneBndrs CorePrepEnv
env [InVar]
bndrs
; body' <- cpeBodyNF env' body
; let rhs' = [InVar] -> CpeApp -> CpeApp
mkCoreLams [InVar]
bndrs' CpeApp
body'
bndr' = InVar
bndr InVar -> Unfolding -> InVar
`setIdUnfolding` Unfolding
evaldUnfolding
InVar -> Int -> InVar
`setIdArity` (InVar -> Bool) -> [InVar] -> Int
forall a. (a -> Bool) -> [a] -> Int
count InVar -> Bool
isId [InVar]
bndrs
; return (bndr', 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 Literal
lit)
| LitNumber LitNumType
LitNumBigNat Integer
i <- Literal
lit
= CorePrepEnv -> Integer -> UniqSM (Floats, CpeApp)
cpeBigNatLit CorePrepEnv
env Integer
i
| Bool
otherwise = (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 { (env', bind_floats, maybe_bind') <- TopLevelFlag
-> CorePrepEnv
-> CoreBind
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
cpeBind TopLevelFlag
NotTopLevel CorePrepEnv
env CoreBind
bind
; (body_floats, body') <- cpeRhsE env' body
; let 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'
; return (bind_floats `appFloats` body_floats, expr') }
cpeRhsE CorePrepEnv
env (Tick CoreTickish
tickish CpeApp
expr)
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
tickish
= do { (floats, body) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
expr
; return (FloatTick tickish `consFloat` floats, body) }
| Bool
otherwise
= do { body <- CorePrepEnv -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
env CpeApp
expr
; return (emptyFloats, mkTick tickish' body) }
where
tickish' :: CoreTickish
tickish' | Breakpoint XBreakpoint 'TickishPassCore
ext Int
n [XTickishId 'TickishPassCore]
fvs Module
modl <- CoreTickish
tickish
= XBreakpoint 'TickishPassCore
-> Int -> [XTickishId 'TickishPassCore] -> Module -> CoreTickish
forall (pass :: TickishPass).
XBreakpoint pass
-> Int -> [XTickishId pass] -> Module -> GenTickish pass
Breakpoint XBreakpoint 'TickishPassCore
ext Int
n ((InVar -> InVar) -> [InVar] -> [InVar]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => CpeApp -> InVar
CpeApp -> InVar
getIdFromTrivialExpr (CpeApp -> InVar) -> (InVar -> CpeApp) -> InVar -> InVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CorePrepEnv -> InVar -> CpeApp
lookupCorePrepEnv CorePrepEnv
env) [InVar]
[XTickishId 'TickishPassCore]
fvs) Module
modl
| Bool
otherwise
= CoreTickish
tickish
cpeRhsE CorePrepEnv
env (Cast CpeApp
expr Coercion
co)
= do { (floats, expr') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
expr
; return (floats, Cast expr' (cpSubstCo env co)) }
cpeRhsE CorePrepEnv
env expr :: CpeApp
expr@(Lam {})
= do { let ([InVar]
bndrs,CpeApp
body) = CpeApp -> ([InVar], CpeApp)
forall b. Expr b -> ([b], Expr b)
collectBinders CpeApp
expr
; (env', bndrs') <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
cpCloneBndrs CorePrepEnv
env [InVar]
bndrs
; body' <- cpeBodyNF env' body
; return (emptyFloats, mkLams bndrs' body') }
cpeRhsE CorePrepEnv
env (Case CpeApp
scrut InVar
bndr Type
_ alts :: [Alt InVar]
alts@[Alt AltCon
con [InVar
covar] CpeApp
_])
| Just CpeApp
rhs <- CpeApp -> InVar -> [Alt InVar] -> Maybe CpeApp
isUnsafeEqualityCase CpeApp
scrut InVar
bndr [Alt InVar]
alts
= do { (floats_scrut, scrut) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeBody CorePrepEnv
env CpeApp
scrut
; (env, bndr') <- cpCloneBndr env bndr
; (env, covar') <- cpCloneCoVarBndr env covar
; (floats_rhs, rhs) <- cpeBody env rhs
; let case_float = CpeApp -> InVar -> AltCon -> [InVar] -> FloatingBind
UnsafeEqualityCase CpeApp
scrut InVar
bndr' AltCon
con [InVar
covar']
floats = Floats -> FloatingBind -> Floats
snocFloat Floats
floats_scrut FloatingBind
case_float Floats -> Floats -> Floats
`appFloats` Floats
floats_rhs
; return (floats, rhs) }
cpeRhsE CorePrepEnv
env (Case CpeApp
scrut InVar
bndr Type
_ [Alt (DataAlt DataCon
dc) [InVar
token_out, InVar
res] CpeApp
rhs])
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc
, (Var InVar
f,[CpeApp
_ty1, CpeApp
_ty2, CpeApp
arg, Var InVar
token_in]) <- CpeApp -> (CpeApp, [CpeApp])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CpeApp
scrut
, InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
seqHashKey
, CpeApp -> Bool
exprOkToDiscard CpeApp
arg
, Var InVar
token_in' <- CorePrepEnv -> InVar -> CpeApp
lookupCorePrepEnv CorePrepEnv
env InVar
token_in
, InVar -> Bool
isDeadBinder InVar
res, InVar -> Bool
isDeadBinder InVar
bndr
= CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE (CorePrepEnv -> InVar -> InVar -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env InVar
token_out InVar
token_in') CpeApp
rhs
cpeRhsE CorePrepEnv
env (Case CpeApp
scrut InVar
bndr Type
ty [Alt InVar]
alts)
= do { (floats, scrut') <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeBody CorePrepEnv
env CpeApp
scrut
; (env', bndr2) <- cpCloneBndr env bndr
; let bndr3 = InVar
bndr2 InVar -> Unfolding -> InVar
`setIdUnfolding` Unfolding
evaldUnfolding
; let 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 InVar] -> Bool
forall b. [Alt b] -> Bool
altsAreExhaustive [Alt InVar]
alts)
= [Alt InVar] -> Maybe CpeApp -> [Alt InVar]
forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
addDefault [Alt InVar]
alts (CpeApp -> Maybe CpeApp
forall a. a -> Maybe a
Just CpeApp
err)
| Bool
otherwise = [Alt InVar]
alts
where err :: CpeApp
err = Type -> String -> CpeApp
mkImpossibleExpr Type
ty String
"cpeRhsE: missing case alternative"
; alts'' <- mapM (sat_alt env') alts'
; case alts'' of
[Alt AltCon
DEFAULT [InVar]
_ CpeApp
rhs]
| let float :: FloatingBind
float = InVar -> CpeApp -> FloatingBind
mkCaseFloat InVar
bndr3 CpeApp
scrut'
-> (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> FloatingBind -> Floats
snocFloat Floats
floats FloatingBind
float, CpeApp
rhs)
[Alt InVar]
_ -> (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp -> InVar -> Type -> [Alt InVar] -> CpeApp
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeApp
scrut' InVar
bndr3 (CorePrepEnv -> Type -> Type
cpSubstTy CorePrepEnv
env Type
ty) [Alt InVar]
alts'') }
where
sat_alt :: CorePrepEnv -> Alt InVar -> UniqSM (Alt InVar)
sat_alt CorePrepEnv
env (Alt AltCon
con [InVar]
bs CpeApp
rhs)
= do { (env2, bs') <- CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
cpCloneBndrs CorePrepEnv
env [InVar]
bs
; rhs' <- cpeBodyNF env2 rhs
; return (Alt con bs' rhs') }
cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
cpeBodyNF :: CorePrepEnv -> CpeApp -> UniqSM CpeApp
cpeBodyNF CorePrepEnv
env CpeApp
expr
= do { (floats, body) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeBody CorePrepEnv
env CpeApp
expr
; return (wrapBinds floats body) }
cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
cpeBody :: CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeBody CorePrepEnv
env CpeApp
expr
= do { (floats1, rhs) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
expr
; (floats2, body) <- rhsToBody rhs
; return (floats1 `appFloats` floats2, 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, expr') <- CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody CpeApp
expr
; return (floats, mkTick t expr') }
rhsToBody (Cast CpeApp
e Coercion
co)
= do { (floats, e') <- CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody CpeApp
e
; return (floats, Cast e' co) }
rhsToBody expr :: CpeApp
expr@(Lam {})
| (InVar -> Bool) -> [InVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all InVar -> Bool
isTyVar [InVar]
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
; fn <- Type -> UniqSM InVar
newVar (HasDebugCallStack => CpeApp -> Type
CpeApp -> Type
exprType CpeApp
rhs)
; let float = CoreBind -> BindInfo -> FloatInfo -> FloatingBind
Float (InVar -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec InVar
fn CpeApp
rhs) BindInfo
LetBound FloatInfo
TopLvlFloatable
; return (unitFloat float, Var fn) }
where
([InVar]
bndrs,CpeApp
_) = CpeApp -> ([InVar], 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 = AIApp CoreArg
| AICast Coercion
| AITick CoreTickish
instance Outputable ArgInfo where
ppr :: ArgInfo -> SDoc
ppr (AIApp 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 (AICast 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 (AITick 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
AIApp 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
AICast Coercion
co ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
as)
go (Tick CoreTickish
tickish CpeApp
fun) [ArgInfo]
as
| Var InVar
vh <- CpeApp
head
, Var InVar
head' <- CorePrepEnv -> InVar -> CpeApp
lookupCorePrepEnv CorePrepEnv
top_env InVar
vh
, InVar -> CoreTickish -> Bool
forall (pass :: TickishPass). InVar -> GenTickish pass -> Bool
etaExpansionTick InVar
head' CoreTickish
tickish
= (CpeApp
head,[ArgInfo]
as')
where
(CpeApp
head,[ArgInfo]
as') = CpeApp -> [ArgInfo] -> (CpeApp, [ArgInfo])
go CpeApp
fun (CoreTickish -> ArgInfo
AITick 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 InVar
f) (AIApp Type{} : AIApp CpeApp
arg : [ArgInfo]
args)
| InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
lazyIdKey
Bool -> Bool -> Bool
|| InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
noinlineIdKey Bool -> Bool -> Bool
|| InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
noinlineConstraintIdKey
Bool -> Bool -> Bool
|| InVar
f InVar -> 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 InVar
f) (AIApp _runtimeRep :: CpeApp
_runtimeRep@Type{} : AIApp _type :: CpeApp
_type@Type{} : AIApp CpeApp
arg : [ArgInfo]
rest)
| InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
runRWKey
, [ArgInfo] -> Bool
has_value_arg (CpeApp -> ArgInfo
AIApp CpeApp
arg ArgInfo -> [ArgInfo] -> [ArgInfo]
forall a. a -> [a] -> [a]
: [ArgInfo]
rest)
= case CpeApp
arg of
Lam InVar
s CpeApp
body -> CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app (CorePrepEnv -> InVar -> InVar -> CorePrepEnv
extendCorePrepEnv CorePrepEnv
env InVar
s InVar
realWorldPrimId) CpeApp
body [ArgInfo]
rest
CpeApp
_ -> CorePrepEnv -> CpeApp -> [ArgInfo] -> UniqSM (Floats, CpeApp)
cpe_app CorePrepEnv
env CpeApp
arg (CpeApp -> ArgInfo
AIApp (InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
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 (AIApp 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 InVar
f) [AIApp (Type Type
ty), AIApp _st_ty :: CpeApp
_st_ty@Type{}, AIApp CpeApp
thing, AIApp CpeApp
token]
| InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
seqHashKey
= do { (floats1, token) <- CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
cpeArg CorePrepEnv
env Demand
topDmd CpeApp
token
; (floats2, thing) <- cpeBody env thing
; case_bndr <- (`setIdUnfolding` evaldUnfolding) <$> newVar ty
; let tup = [CpeApp] -> CpeApp
mkCoreUnboxedTuple [CpeApp
token, InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
case_bndr]
; let float = InVar -> CpeApp -> FloatingBind
mkCaseFloat InVar
case_bndr CpeApp
thing
; return (floats1 `appFloats` floats2 `snocFloat` float, tup) }
cpe_app CorePrepEnv
env (Var InVar
v) [ArgInfo]
args
= do { v1 <- InVar -> UniqSM InVar
fiddleCCall InVar
v
; let e2 = CorePrepEnv -> InVar -> CpeApp
lookupCorePrepEnv CorePrepEnv
env InVar
v1
hd = CpeApp -> Maybe InVar
getIdFromTrivialExpr_maybe CpeApp
e2
min_arity = case Maybe InVar
hd of
Just InVar
v_hd -> if InVar -> Bool
hasNoBinding InVar
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
$! (InVar -> Int
idArity InVar
v_hd) else Maybe Int
forall a. Maybe a
Nothing
Maybe InVar
Nothing -> Maybe Int
forall a. Maybe a
Nothing
; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity
; mb_saturate hd app floats unsat_ticks depth }
where
depth :: Int
depth = [ArgInfo] -> Int
val_args [ArgInfo]
args
stricts :: [Demand]
stricts = case InVar -> DmdSig
idDmdSig InVar
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 { (fun_floats, fun') <- CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
cpeArg CorePrepEnv
env Demand
evalDmd CpeApp
fun
; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing
; mb_saturate Nothing app floats unsat_ticks (val_args 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
AICast {} -> [ArgInfo] -> t -> t
go [ArgInfo]
infos t
n
AITick 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
AIApp 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 InVar
-> CpeApp -> a -> [CoreTickish] -> Int -> UniqSM (a, CpeApp)
mb_saturate Maybe InVar
head CpeApp
app a
floats [CoreTickish]
unsat_ticks Int
depth =
case Maybe InVar
head of
Just InVar
fn_id -> do { sat_app <- InVar -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeApp
maybeSaturate InVar
fn_id CpeApp
app Int
depth [CoreTickish]
unsat_ticks
; return (floats, sat_app) }
Maybe InVar
_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
AIApp (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
AIApp (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
AIApp 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, [])
(fs, arg') <- CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
cpeArg CorePrepEnv
top_env Demand
ss1 CpeApp
arg
rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1)
AICast 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
AITick 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
snocFloat 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 InVar
f `App` CpeApp
_ `App` CpeApp
_) = InVar
f InVar -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
lazyIdKey
isLazyExpr CpeApp
_ = Bool
False
cpeArg :: CorePrepEnv -> Demand
-> CoreArg -> UniqSM (Floats, CpeArg)
cpeArg :: CorePrepEnv -> Demand -> CpeApp -> UniqSM (Floats, CpeApp)
cpeArg CorePrepEnv
env Demand
dmd CpeApp
arg
= do { (floats1, arg1) <- CorePrepEnv -> CpeApp -> UniqSM (Floats, CpeApp)
cpeRhsE CorePrepEnv
env CpeApp
arg
; let arg_ty = HasDebugCallStack => CpeApp -> Type
CpeApp -> Type
exprType CpeApp
arg1
lev = HasDebugCallStack => Type -> Levity
Type -> Levity
typeLevity Type
arg_ty
dec = RecFlag -> Demand -> Levity -> Floats -> CpeApp -> FloatDecision
wantFloatLocal RecFlag
NonRecursive Demand
dmd Levity
lev Floats
floats1 CpeApp
arg1
; (floats2, arg2) <- executeFloatDecision dec floats1 arg1
; if exprIsTrivial arg2
then return (floats2, arg2)
else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty
; let arity = CorePrepEnv -> FloatDecision -> Floats -> CpeApp -> Int
cpeArgArity CorePrepEnv
env FloatDecision
dec Floats
floats1 CpeApp
arg2
arg3 = Int -> CpeApp -> CpeApp
cpeEtaExpand Int
arity CpeApp
arg2
; let (arg_float, v') = mkNonRecFloat env lev v arg3
; return (snocFloat floats2 arg_float, varToCoreExpr v') }
}
cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CoreArg -> Arity
cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CpeApp -> Int
cpeArgArity CorePrepEnv
env FloatDecision
float_decision Floats
floats1 CpeApp
arg
| FloatDecision
FloatNone <- FloatDecision
float_decision
, Bool -> Bool
not (Floats -> Bool
isEmptyFloats Floats
floats1)
, Floats -> FloatInfo
fs_info Floats
floats1 FloatInfo -> FloatInfo -> Bool
`floatsAtLeastAsFarAs` FloatInfo
LazyContextFloatable
= Int
0
| Just ArityOpts
ao <- CorePrepConfig -> Maybe ArityOpts
cp_arityOpts (CorePrepEnv -> CorePrepConfig
cpe_config CorePrepEnv
env)
, Bool -> Bool
not (CpeApp -> Bool
eta_would_wreck_join CpeApp
arg)
= case HasDebugCallStack => ArityOpts -> CpeApp -> Maybe SafeArityType
ArityOpts -> CpeApp -> Maybe SafeArityType
exprEtaExpandArity ArityOpts
ao CpeApp
arg of
Maybe SafeArityType
Nothing -> Int
0
Just SafeArityType
at -> SafeArityType -> Int
arityTypeArity SafeArityType
at
| Bool
otherwise
= CpeApp -> Int
exprArity CpeApp
arg
eta_would_wreck_join :: CoreExpr -> Bool
eta_would_wreck_join :: CpeApp -> Bool
eta_would_wreck_join (Let CoreBind
bs CpeApp
e) = CoreBind -> Bool
isJoinBind CoreBind
bs Bool -> Bool -> Bool
|| CpeApp -> Bool
eta_would_wreck_join CpeApp
e
eta_would_wreck_join (Lam InVar
_ CpeApp
e) = CpeApp -> Bool
eta_would_wreck_join CpeApp
e
eta_would_wreck_join (Cast CpeApp
e Coercion
_) = CpeApp -> Bool
eta_would_wreck_join CpeApp
e
eta_would_wreck_join (Tick CoreTickish
_ CpeApp
e) = CpeApp -> Bool
eta_would_wreck_join CpeApp
e
eta_would_wreck_join (Case CpeApp
_ InVar
_ Type
_ [Alt InVar]
alts) = (CpeApp -> Bool) -> [CpeApp] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CpeApp -> Bool
eta_would_wreck_join ([Alt InVar] -> [CpeApp]
forall b. [Alt b] -> [Expr b]
rhssOfAlts [Alt InVar]
alts)
eta_would_wreck_join CpeApp
_ = Bool
False
maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs
maybeSaturate :: InVar -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeApp
maybeSaturate InVar
fn CpeApp
expr Int
n_args [CoreTickish]
unsat_ticks
| InVar -> Bool
hasNoBinding InVar
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 (InVar -> Bool
isJoinId InVar
fn))
( InVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr InVar
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 (InVar -> Maybe [CbvMark]
idCbvMarks_maybe InVar
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
<+> JoinPointHood -> SDoc
forall a. Outputable a => a -> SDoc
ppr (InVar -> JoinPointHood
idJoinPointHood InVar
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 = InVar -> Int
idCbvMarkArity InVar
fn
fn_arity :: Int
fn_arity = InVar -> Int
idArity InVar
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. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"maybeSaturate" (Maybe [CbvMark] -> Int) -> Maybe [CbvMark] -> Int
forall a b. (a -> b) -> a -> b
$ (InVar -> Maybe [CbvMark]
idCbvMarks_maybe InVar
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 BindInfo
= CaseBound
| LetBound
deriving BindInfo -> BindInfo -> Bool
(BindInfo -> BindInfo -> Bool)
-> (BindInfo -> BindInfo -> Bool) -> Eq BindInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BindInfo -> BindInfo -> Bool
== :: BindInfo -> BindInfo -> Bool
$c/= :: BindInfo -> BindInfo -> Bool
/= :: BindInfo -> BindInfo -> Bool
Eq
data FloatInfo
= TopLvlFloatable
| LazyContextFloatable
| StrictContextFloatable
deriving FloatInfo -> FloatInfo -> Bool
(FloatInfo -> FloatInfo -> Bool)
-> (FloatInfo -> FloatInfo -> Bool) -> Eq FloatInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FloatInfo -> FloatInfo -> Bool
== :: FloatInfo -> FloatInfo -> Bool
$c/= :: FloatInfo -> FloatInfo -> Bool
/= :: FloatInfo -> FloatInfo -> Bool
Eq
instance Outputable BindInfo where
ppr :: BindInfo -> SDoc
ppr BindInfo
CaseBound = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Case"
ppr BindInfo
LetBound = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Let"
instance Outputable FloatInfo where
ppr :: FloatInfo -> SDoc
ppr FloatInfo
TopLvlFloatable = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"top-lvl"
ppr FloatInfo
LazyContextFloatable = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"lzy-ctx"
ppr FloatInfo
StrictContextFloatable = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"str-ctx"
data FloatingBind
= Float !CoreBind !BindInfo !FloatInfo
| UnsafeEqualityCase !CoreExpr !CoreBndr !AltCon ![CoreBndr]
| FloatTick CoreTickish
data Floats
= Floats
{ Floats -> FloatInfo
fs_info :: !FloatInfo
, Floats -> OrdList FloatingBind
fs_binds :: !(OrdList FloatingBind)
}
instance Outputable FloatingBind where
ppr :: FloatingBind -> SDoc
ppr (Float CoreBind
b BindInfo
bi FloatInfo
fi) = BindInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr BindInfo
bi SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FloatInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatInfo
fi SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
b
ppr (FloatTick CoreTickish
t) = CoreTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreTickish
t
ppr (UnsafeEqualityCase CpeApp
scrut InVar
b AltCon
k [InVar]
bs) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"case" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CpeApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeApp
scrut
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
<+> InVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr InVar
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 [InVar]
bs of
[] -> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
k
[InVar]
_ -> 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
<+> [InVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InVar]
bs)
instance Outputable Floats where
ppr :: Floats -> SDoc
ppr (Floats FloatInfo
info OrdList FloatingBind
binds) = 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 (FloatInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatInfo
info) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (OrdList FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr OrdList FloatingBind
binds)
lubFloatInfo :: FloatInfo -> FloatInfo -> FloatInfo
lubFloatInfo :: FloatInfo -> FloatInfo -> FloatInfo
lubFloatInfo FloatInfo
StrictContextFloatable FloatInfo
_ = FloatInfo
StrictContextFloatable
lubFloatInfo FloatInfo
_ FloatInfo
StrictContextFloatable = FloatInfo
StrictContextFloatable
lubFloatInfo FloatInfo
LazyContextFloatable FloatInfo
_ = FloatInfo
LazyContextFloatable
lubFloatInfo FloatInfo
_ FloatInfo
LazyContextFloatable = FloatInfo
LazyContextFloatable
lubFloatInfo FloatInfo
TopLvlFloatable FloatInfo
TopLvlFloatable = FloatInfo
TopLvlFloatable
floatsAtLeastAsFarAs :: FloatInfo -> FloatInfo -> Bool
floatsAtLeastAsFarAs :: FloatInfo -> FloatInfo -> Bool
floatsAtLeastAsFarAs FloatInfo
l FloatInfo
r = FloatInfo
l FloatInfo -> FloatInfo -> FloatInfo
`lubFloatInfo` FloatInfo
r FloatInfo -> FloatInfo -> Bool
forall a. Eq a => a -> a -> Bool
== FloatInfo
r
emptyFloats :: Floats
emptyFloats :: Floats
emptyFloats = FloatInfo -> OrdList FloatingBind -> Floats
Floats FloatInfo
TopLvlFloatable OrdList FloatingBind
forall a. OrdList a
nilOL
isEmptyFloats :: Floats -> Bool
isEmptyFloats :: Floats -> Bool
isEmptyFloats (Floats FloatInfo
_ OrdList FloatingBind
b) = OrdList FloatingBind -> Bool
forall a. OrdList a -> Bool
isNilOL OrdList FloatingBind
b
getFloats :: Floats -> OrdList FloatingBind
getFloats :: Floats -> OrdList FloatingBind
getFloats = Floats -> OrdList FloatingBind
fs_binds
unitFloat :: FloatingBind -> Floats
unitFloat :: FloatingBind -> Floats
unitFloat = Floats -> FloatingBind -> Floats
snocFloat Floats
emptyFloats
floatInfo :: FloatingBind -> FloatInfo
floatInfo :: FloatingBind -> FloatInfo
floatInfo (Float CoreBind
_ BindInfo
_ FloatInfo
info) = FloatInfo
info
floatInfo UnsafeEqualityCase{} = FloatInfo
LazyContextFloatable
floatInfo FloatTick{} = FloatInfo
TopLvlFloatable
snocFloat :: Floats -> FloatingBind -> Floats
snocFloat :: Floats -> FloatingBind -> Floats
snocFloat Floats
floats FloatingBind
fb =
Floats { fs_info :: FloatInfo
fs_info = FloatInfo -> FloatInfo -> FloatInfo
lubFloatInfo (Floats -> FloatInfo
fs_info Floats
floats) (FloatingBind -> FloatInfo
floatInfo FloatingBind
fb)
, fs_binds :: OrdList FloatingBind
fs_binds = Floats -> OrdList FloatingBind
fs_binds Floats
floats OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> a -> OrdList a
`snocOL` FloatingBind
fb }
consFloat :: FloatingBind -> Floats -> Floats
consFloat :: FloatingBind -> Floats -> Floats
consFloat FloatingBind
fb Floats
floats =
Floats { fs_info :: FloatInfo
fs_info = FloatInfo -> FloatInfo -> FloatInfo
lubFloatInfo (Floats -> FloatInfo
fs_info Floats
floats) (FloatingBind -> FloatInfo
floatInfo FloatingBind
fb)
, fs_binds :: OrdList FloatingBind
fs_binds = FloatingBind
fb FloatingBind -> OrdList FloatingBind -> OrdList FloatingBind
forall a. a -> OrdList a -> OrdList a
`consOL` Floats -> OrdList FloatingBind
fs_binds Floats
floats }
appFloats :: Floats -> Floats -> Floats
appFloats :: Floats -> Floats -> Floats
appFloats Floats
outer Floats
inner =
Floats { fs_info :: FloatInfo
fs_info = FloatInfo -> FloatInfo -> FloatInfo
lubFloatInfo (Floats -> FloatInfo
fs_info Floats
outer) (Floats -> FloatInfo
fs_info Floats
inner)
, fs_binds :: OrdList FloatingBind
fs_binds = Floats -> OrdList FloatingBind
fs_binds Floats
outer OrdList FloatingBind
-> OrdList FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Floats -> OrdList FloatingBind
fs_binds Floats
inner }
zipFloats :: Floats -> Floats -> Floats
zipFloats :: Floats -> Floats -> Floats
zipFloats = Floats -> Floats -> Floats
appFloats
zipManyFloats :: [Floats] -> Floats
zipManyFloats :: [Floats] -> Floats
zipManyFloats = (Floats -> Floats -> Floats) -> Floats -> [Floats] -> Floats
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Floats -> Floats -> Floats
zipFloats Floats
emptyFloats
data FloatInfoArgs
= FIA
{ FloatInfoArgs -> Levity
fia_levity :: Levity
, FloatInfoArgs -> Demand
fia_demand :: Demand
, FloatInfoArgs -> Bool
fia_is_hnf :: Bool
, FloatInfoArgs -> Bool
fia_is_triv :: Bool
, FloatInfoArgs -> Bool
fia_is_string :: Bool
, FloatInfoArgs -> Bool
fia_is_dc_worker :: Bool
, FloatInfoArgs -> Bool
fia_ok_for_spec :: Bool
}
defFloatInfoArgs :: Id -> CoreExpr -> FloatInfoArgs
defFloatInfoArgs :: InVar -> CpeApp -> FloatInfoArgs
defFloatInfoArgs InVar
bndr CpeApp
rhs
= FIA
{ fia_levity :: Levity
fia_levity = HasDebugCallStack => Type -> Levity
Type -> Levity
typeLevity (InVar -> Type
idType InVar
bndr)
, fia_demand :: Demand
fia_demand = InVar -> Demand
idDemandInfo InVar
bndr
, fia_is_hnf :: Bool
fia_is_hnf = CpeApp -> Bool
exprIsHNF CpeApp
rhs
, fia_is_triv :: Bool
fia_is_triv = CpeApp -> Bool
exprIsTrivial CpeApp
rhs
, fia_is_string :: Bool
fia_is_string = CpeApp -> Bool
exprIsTickedString CpeApp
rhs
, fia_is_dc_worker :: Bool
fia_is_dc_worker = Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isJust (InVar -> Maybe DataCon
isDataConId_maybe InVar
bndr)
, fia_ok_for_spec :: Bool
fia_ok_for_spec = Bool
False
}
decideFloatInfo :: FloatInfoArgs -> (BindInfo, FloatInfo)
decideFloatInfo :: FloatInfoArgs -> (BindInfo, FloatInfo)
decideFloatInfo FIA{fia_levity :: FloatInfoArgs -> Levity
fia_levity=Levity
lev, fia_demand :: FloatInfoArgs -> Demand
fia_demand=Demand
dmd, fia_is_hnf :: FloatInfoArgs -> Bool
fia_is_hnf=Bool
is_hnf,
fia_is_triv :: FloatInfoArgs -> Bool
fia_is_triv=Bool
is_triv, fia_is_string :: FloatInfoArgs -> Bool
fia_is_string=Bool
is_string,
fia_is_dc_worker :: FloatInfoArgs -> Bool
fia_is_dc_worker=Bool
is_dc_worker, fia_ok_for_spec :: FloatInfoArgs -> Bool
fia_ok_for_spec=Bool
ok_for_spec}
| Levity
Lifted <- Levity
lev, Bool
is_hnf, Bool -> Bool
not Bool
is_triv = (BindInfo
LetBound, FloatInfo
TopLvlFloatable)
| Bool
is_dc_worker = (BindInfo
LetBound, FloatInfo
TopLvlFloatable)
| Bool
is_string = (BindInfo
CaseBound, FloatInfo
TopLvlFloatable)
| Bool
ok_for_spec = (BindInfo
CaseBound, case Levity
lev of Levity
Unlifted -> FloatInfo
LazyContextFloatable
Levity
Lifted -> FloatInfo
TopLvlFloatable)
| Levity
Unlifted <- Levity
lev = (BindInfo
CaseBound, FloatInfo
StrictContextFloatable)
| Demand -> Bool
isStrUsedDmd Demand
dmd = (BindInfo
CaseBound, FloatInfo
StrictContextFloatable)
| Levity
Lifted <- Levity
lev = (BindInfo
LetBound, FloatInfo
TopLvlFloatable)
mkCaseFloat :: Id -> CpeRhs -> FloatingBind
mkCaseFloat :: InVar -> CpeApp -> FloatingBind
mkCaseFloat InVar
bndr CpeApp
scrut
=
CoreBind -> BindInfo -> FloatInfo -> FloatingBind
Float (InVar -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec InVar
bndr CpeApp
scrut) BindInfo
bound FloatInfo
info
where
!(BindInfo
bound, FloatInfo
info) = FloatInfoArgs -> (BindInfo, FloatInfo)
decideFloatInfo (FloatInfoArgs -> (BindInfo, FloatInfo))
-> FloatInfoArgs -> (BindInfo, FloatInfo)
forall a b. (a -> b) -> a -> b
$ (InVar -> CpeApp -> FloatInfoArgs
defFloatInfoArgs InVar
bndr CpeApp
scrut)
{ fia_demand = evalDmd
, fia_is_dc_worker = False
, fia_ok_for_spec = False
}
mkNonRecFloat :: CorePrepEnv -> Levity -> Id -> CpeRhs -> (FloatingBind, Id)
mkNonRecFloat :: CorePrepEnv -> Levity -> InVar -> CpeApp -> (FloatingBind, InVar)
mkNonRecFloat CorePrepEnv
env Levity
lev InVar
bndr CpeApp
rhs
=
(CoreBind -> BindInfo -> FloatInfo -> FloatingBind
Float (InVar -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec InVar
bndr' CpeApp
rhs) BindInfo
bound FloatInfo
info, InVar
bndr')
where
!(BindInfo
bound, FloatInfo
info) = FloatInfoArgs -> (BindInfo, FloatInfo)
decideFloatInfo (FloatInfoArgs -> (BindInfo, FloatInfo))
-> FloatInfoArgs -> (BindInfo, FloatInfo)
forall a b. (a -> b) -> a -> b
$ (InVar -> CpeApp -> FloatInfoArgs
defFloatInfoArgs InVar
bndr CpeApp
rhs)
{ fia_levity = lev
, fia_is_hnf = is_hnf
, fia_ok_for_spec = ok_for_spec
}
is_hnf :: Bool
is_hnf = CpeApp -> Bool
exprIsHNF CpeApp
rhs
ok_for_spec :: Bool
ok_for_spec = (InVar -> Bool) -> CpeApp -> Bool
exprOkForSpecEval (Bool -> Bool
not (Bool -> Bool) -> (InVar -> Bool) -> InVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InVar -> Bool
is_rec_call) CpeApp
rhs
is_rec_call :: InVar -> Bool
is_rec_call = (InVar -> UnVarSet -> Bool
`elemUnVarSet` CorePrepEnv -> UnVarSet
cpe_rec_ids CorePrepEnv
env)
bndr' :: InVar
bndr' | Bool
is_hnf = InVar
bndr InVar -> Unfolding -> InVar
`setIdUnfolding` Unfolding
evaldUnfolding
| Bool
otherwise = InVar
bndr
wrapBinds :: Floats -> CpeBody -> CpeBody
wrapBinds :: Floats -> CpeApp -> CpeApp
wrapBinds Floats
floats 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 (Floats -> OrdList FloatingBind
getFloats Floats
floats)
where
mk_bind :: FloatingBind -> CpeApp -> CpeApp
mk_bind f :: FloatingBind
f@(Float CoreBind
bind BindInfo
CaseBound FloatInfo
_) CpeApp
body
| NonRec InVar
bndr CpeApp
rhs <- CoreBind
bind
= CpeApp -> InVar -> CpeApp -> CpeApp
mkDefaultCase CpeApp
rhs InVar
bndr CpeApp
body
| Bool
otherwise
= String -> SDoc -> CpeApp
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"wrapBinds" (FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
f)
mk_bind (Float CoreBind
bind BindInfo
_ FloatInfo
_) CpeApp
body
= CoreBind -> CpeApp -> CpeApp
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind CpeApp
body
mk_bind (UnsafeEqualityCase CpeApp
scrut InVar
b AltCon
con [InVar]
bs) CpeApp
body
= CpeApp -> InVar -> AltCon -> [InVar] -> CpeApp -> CpeApp
mkSingleAltCase CpeApp
scrut InVar
b AltCon
con [InVar]
bs CpeApp
body
mk_bind (FloatTick CoreTickish
tickish) CpeApp
body
= CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
tickish CpeApp
body
deFloatTop :: Floats -> [CoreBind]
deFloatTop :: Floats -> CoreProgram
deFloatTop Floats
floats
= (FloatingBind -> CoreProgram -> CoreProgram)
-> CoreProgram -> OrdList FloatingBind -> CoreProgram
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL FloatingBind -> CoreProgram -> CoreProgram
get [] (Floats -> OrdList FloatingBind
getFloats Floats
floats)
where
get :: FloatingBind -> CoreProgram -> CoreProgram
get (Float CoreBind
b BindInfo
_ FloatInfo
TopLvlFloatable) CoreProgram
bs
= CoreBind -> CoreBind
get_bind CoreBind
b 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
"deFloatTop" (FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
b)
get_bind :: CoreBind -> CoreBind
get_bind (NonRec InVar
x CpeApp
e) = InVar -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec InVar
x (CpeApp -> CpeApp
occurAnalyseExpr CpeApp
e)
get_bind (Rec [(InVar, CpeApp)]
xes) = [(InVar, CpeApp)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(InVar
x, CpeApp -> CpeApp
occurAnalyseExpr CpeApp
e) | (InVar
x, CpeApp
e) <- [(InVar, CpeApp)]
xes]
data FloatDecision
= FloatNone
| FloatAll
instance Outputable FloatDecision where
ppr :: FloatDecision -> SDoc
ppr FloatDecision
FloatNone = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"none"
ppr FloatDecision
FloatAll = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"all"
executeFloatDecision :: FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)
executeFloatDecision :: FloatDecision -> Floats -> CpeApp -> UniqSM (Floats, CpeApp)
executeFloatDecision FloatDecision
dec Floats
floats CpeApp
rhs
= case FloatDecision
dec of
FloatDecision
FloatAll -> (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
floats, CpeApp
rhs)
FloatDecision
FloatNone
| 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)
| Bool
otherwise -> do { (floats', body) <- CpeApp -> UniqSM (Floats, CpeApp)
rhsToBody CpeApp
rhs
; return (emptyFloats, wrapBinds floats $
wrapBinds floats' body) }
wantFloatTop :: Floats -> FloatDecision
wantFloatTop :: Floats -> FloatDecision
wantFloatTop Floats
fs
| Floats -> FloatInfo
fs_info Floats
fs FloatInfo -> FloatInfo -> Bool
`floatsAtLeastAsFarAs` FloatInfo
TopLvlFloatable = FloatDecision
FloatAll
| Bool
otherwise = FloatDecision
FloatNone
wantFloatLocal :: RecFlag -> Demand -> Levity -> Floats -> CpeRhs -> FloatDecision
wantFloatLocal :: RecFlag -> Demand -> Levity -> Floats -> CpeApp -> FloatDecision
wantFloatLocal RecFlag
is_rec Demand
rhs_dmd Levity
rhs_lev Floats
floats CpeApp
rhs
| Floats -> Bool
isEmptyFloats Floats
floats
Bool -> Bool -> Bool
|| Demand -> Bool
isStrUsedDmd Demand
rhs_dmd
Bool -> Bool -> Bool
|| Levity
rhs_lev Levity -> Levity -> Bool
forall a. Eq a => a -> a -> Bool
== Levity
Unlifted
Bool -> Bool -> Bool
|| (Floats -> FloatInfo
fs_info Floats
floats FloatInfo -> FloatInfo -> Bool
`floatsAtLeastAsFarAs` FloatInfo
max_float_info Bool -> Bool -> Bool
&& CpeApp -> Bool
exprIsHNF CpeApp
rhs)
= FloatDecision
FloatAll
| Bool
otherwise
= FloatDecision
FloatNone
where
max_float_info :: FloatInfo
max_float_info | RecFlag -> Bool
isRec RecFlag
is_rec = FloatInfo
TopLvlFloatable
| Bool
otherwise = FloatInfo
LazyContextFloatable
data CorePrepConfig = CorePrepConfig
{ CorePrepConfig -> Bool
cp_catchNonexhaustiveCases :: !Bool
, CorePrepConfig -> Platform
cp_platform :: Platform
, CorePrepConfig -> Maybe ArityOpts
cp_arityOpts :: !(Maybe ArityOpts)
}
data CorePrepEnv
= CPE { CorePrepEnv -> CorePrepConfig
cpe_config :: !CorePrepConfig
, CorePrepEnv -> Subst
cpe_subst :: Subst
, CorePrepEnv -> UnVarSet
cpe_rec_ids :: UnVarSet
}
mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
mkInitialCorePrepEnv CorePrepConfig
cfg = CPE
{ cpe_config :: CorePrepConfig
cpe_config = CorePrepConfig
cfg
, cpe_subst :: Subst
cpe_subst = Subst
emptySubst
, cpe_rec_ids :: UnVarSet
cpe_rec_ids = UnVarSet
emptyUnVarSet
}
extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
extendCorePrepEnv :: CorePrepEnv -> InVar -> InVar -> CorePrepEnv
extendCorePrepEnv cpe :: CorePrepEnv
cpe@(CPE { cpe_subst :: CorePrepEnv -> Subst
cpe_subst = Subst
subst }) InVar
id InVar
id'
= CorePrepEnv
cpe { cpe_subst = subst2 }
where
subst1 :: Subst
subst1 = Subst -> InVar -> Subst
extendSubstInScope Subst
subst InVar
id'
subst2 :: Subst
subst2 = Subst -> InVar -> CpeApp -> Subst
extendIdSubst Subst
subst1 InVar
id (InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
id')
extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
extendCorePrepEnvList :: CorePrepEnv -> [(InVar, InVar)] -> CorePrepEnv
extendCorePrepEnvList cpe :: CorePrepEnv
cpe@(CPE { cpe_subst :: CorePrepEnv -> Subst
cpe_subst = Subst
subst }) [(InVar, InVar)]
prs
= CorePrepEnv
cpe { cpe_subst = subst2 }
where
subst1 :: Subst
subst1 = Subst -> [InVar] -> Subst
extendSubstInScopeList Subst
subst (((InVar, InVar) -> InVar) -> [(InVar, InVar)] -> [InVar]
forall a b. (a -> b) -> [a] -> [b]
map (InVar, InVar) -> InVar
forall a b. (a, b) -> b
snd [(InVar, InVar)]
prs)
subst2 :: Subst
subst2 = Subst -> [(InVar, CpeApp)] -> Subst
extendIdSubstList Subst
subst1 [(InVar
id, InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
id') | (InVar
id,InVar
id') <- [(InVar, InVar)]
prs]
extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
extendCorePrepEnvExpr :: CorePrepEnv -> InVar -> CpeApp -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
cpe InVar
id CpeApp
expr
= CorePrepEnv
cpe { cpe_subst = extendIdSubst (cpe_subst cpe) id expr }
lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
lookupCorePrepEnv :: CorePrepEnv -> InVar -> CpeApp
lookupCorePrepEnv CorePrepEnv
cpe InVar
id
= case HasDebugCallStack => Subst -> InVar -> Maybe CpeApp
Subst -> InVar -> Maybe CpeApp
lookupIdSubst_maybe (CorePrepEnv -> Subst
cpe_subst CorePrepEnv
cpe) InVar
id of
Just CpeApp
e -> CpeApp
e
Maybe CpeApp
Nothing -> InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
id
enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv
enterRecGroupRHSs :: CorePrepEnv -> [InVar] -> CorePrepEnv
enterRecGroupRHSs CorePrepEnv
env [InVar]
grp
= CorePrepEnv
env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) }
cpSubstTy :: CorePrepEnv -> Type -> Type
cpSubstTy :: CorePrepEnv -> Type -> Type
cpSubstTy (CPE { cpe_subst :: CorePrepEnv -> Subst
cpe_subst = Subst
subst }) Type
ty = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
ty
cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
cpSubstCo (CPE { cpe_subst :: CorePrepEnv -> Subst
cpe_subst = Subst
subst }) Coercion
co = HasDebugCallStack => Subst -> Coercion -> Coercion
Subst -> Coercion -> Coercion
substCo Subst
subst Coercion
co
cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
cpCloneBndrs CorePrepEnv
env [InVar]
bs = (CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar))
-> CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [InVar])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
cpCloneBndr CorePrepEnv
env [InVar]
bs
cpCloneCoVarBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
cpCloneCoVarBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
cpCloneCoVarBndr env :: CorePrepEnv
env@(CPE { cpe_subst :: CorePrepEnv -> Subst
cpe_subst = Subst
subst }) InVar
covar
= Bool
-> SDoc
-> UniqSM (CorePrepEnv, InVar)
-> UniqSM (CorePrepEnv, InVar)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (InVar -> Bool
isCoVar InVar
covar) (InVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr InVar
covar) (UniqSM (CorePrepEnv, InVar) -> UniqSM (CorePrepEnv, InVar))
-> UniqSM (CorePrepEnv, InVar) -> UniqSM (CorePrepEnv, InVar)
forall a b. (a -> b) -> a -> b
$
do { uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let covar1 = InVar -> Unique -> InVar
setVarUnique InVar
covar Unique
uniq
covar2 = (Type -> Type) -> InVar -> InVar
updateVarType (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst) InVar
covar1
subst1 = Subst -> InVar -> InVar -> Subst
extendTCvSubstWithClone Subst
subst InVar
covar InVar
covar2
; return (env { cpe_subst = subst1 }, covar2) }
cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, InVar)
cpCloneBndr env :: CorePrepEnv
env@(CPE { cpe_subst :: CorePrepEnv -> Subst
cpe_subst = Subst
subst }) InVar
bndr
| InVar -> Bool
isTyCoVar InVar
bndr
= if Subst -> Bool
isEmptyTCvSubst Subst
subst
then (CorePrepEnv, InVar) -> UniqSM (CorePrepEnv, InVar)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv
env { cpe_subst = extendSubstInScope subst bndr }, InVar
bndr)
else
let bndr1 :: InVar
bndr1 = (Type -> Type) -> InVar -> InVar
updateVarType (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst) InVar
bndr
subst1 :: Subst
subst1 = Subst -> InVar -> InVar -> Subst
extendTCvSubstWithClone Subst
subst InVar
bndr InVar
bndr1
in (CorePrepEnv, InVar) -> UniqSM (CorePrepEnv, InVar)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv
env { cpe_subst = subst1 }, InVar
bndr1)
| Bool
otherwise
= do { bndr1 <- InVar -> UniqSM InVar
forall {m :: * -> *}. MonadUnique m => InVar -> m InVar
clone_it InVar
bndr
; let bndr2 = (Type -> Type) -> InVar -> InVar
updateIdTypeAndMult (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst) InVar
bndr1
; let !unfolding' = Unfolding -> Unfolding
trimUnfolding (InVar -> Unfolding
realIdUnfolding InVar
bndr)
bndr3 = InVar
bndr2 InVar -> Unfolding -> InVar
`setIdUnfolding` Unfolding
unfolding'
InVar -> RuleInfo -> InVar
`setIdSpecialisation` RuleInfo
emptyRuleInfo
; return (extendCorePrepEnv env bndr bndr3, bndr3) }
where
clone_it :: InVar -> m InVar
clone_it InVar
bndr
| InVar -> Bool
isLocalId InVar
bndr
= do { uniq <- m Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; return (setVarUnique bndr uniq) }
| Bool
otherwise
= InVar -> m InVar
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return InVar
bndr
fiddleCCall :: Id -> UniqSM Id
fiddleCCall :: InVar -> UniqSM InVar
fiddleCCall InVar
id
| InVar -> Bool
isFCallId InVar
id = (InVar
id InVar -> Unique -> InVar
`setVarUnique`) (Unique -> InVar) -> UniqSM Unique -> UniqSM InVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
| Bool
otherwise = InVar -> UniqSM InVar
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return InVar
id
newVar :: Type -> UniqSM Id
newVar :: Type -> UniqSM InVar
newVar Type
ty
= Type -> ()
seqType Type
ty () -> UniqSM InVar -> UniqSM InVar
forall a b. a -> b -> b
`seq` FastString -> Type -> Type -> UniqSM InVar
forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m InVar
mkSysLocalOrCoVarM (String -> FastString
fsLit String
"sat") Type
ManyTy Type
ty
wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
wrapTicks :: Floats -> CpeApp -> (Floats, CpeApp)
wrapTicks Floats
floats CpeApp
expr
| (Floats
floats1, OrdList CoreTickish
ticks1) <- ((OrdList FloatingBind, OrdList CoreTickish)
-> FloatingBind -> (OrdList FloatingBind, OrdList CoreTickish))
-> Floats -> (Floats, OrdList CoreTickish)
forall {a}.
((OrdList FloatingBind, OrdList a)
-> FloatingBind -> (OrdList FloatingBind, OrdList a))
-> Floats -> (Floats, OrdList a)
fold_fun (OrdList FloatingBind, OrdList CoreTickish)
-> FloatingBind -> (OrdList FloatingBind, OrdList CoreTickish)
go Floats
floats
= (Floats
floats1, (CoreTickish -> CpeApp -> CpeApp)
-> CpeApp -> OrdList CoreTickish -> CpeApp
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL CoreTickish -> CpeApp -> CpeApp
mkTick CpeApp
expr OrdList CoreTickish
ticks1)
where fold_fun :: ((OrdList FloatingBind, OrdList a)
-> FloatingBind -> (OrdList FloatingBind, OrdList a))
-> Floats -> (Floats, OrdList a)
fold_fun (OrdList FloatingBind, OrdList a)
-> FloatingBind -> (OrdList FloatingBind, OrdList a)
f Floats
floats =
let (OrdList FloatingBind
binds, OrdList a
ticks) = ((OrdList FloatingBind, OrdList a)
-> FloatingBind -> (OrdList FloatingBind, OrdList a))
-> (OrdList FloatingBind, OrdList a)
-> OrdList FloatingBind
-> (OrdList FloatingBind, OrdList a)
forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL (OrdList FloatingBind, OrdList a)
-> FloatingBind -> (OrdList FloatingBind, OrdList a)
f (OrdList FloatingBind
forall a. OrdList a
nilOL,OrdList a
forall a. OrdList a
nilOL) (Floats -> OrdList FloatingBind
fs_binds Floats
floats)
in (Floats
floats { fs_binds = binds }, OrdList a
ticks)
go :: (OrdList FloatingBind, OrdList CoreTickish)
-> FloatingBind -> (OrdList FloatingBind, OrdList CoreTickish)
go (OrdList FloatingBind
flt_binds, OrdList CoreTickish
ticks) (FloatTick CoreTickish
t)
= Bool
-> (OrdList FloatingBind, OrdList CoreTickish)
-> (OrdList FloatingBind, OrdList 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)
(OrdList FloatingBind
flt_binds, if (CoreTickish -> Bool) -> OrdList 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) OrdList CoreTickish
ticks
then OrdList CoreTickish
ticks else OrdList CoreTickish
ticks OrdList CoreTickish -> CoreTickish -> OrdList CoreTickish
forall a. OrdList a -> a -> OrdList a
`snocOL` CoreTickish
t)
go (OrdList FloatingBind
flt_binds, OrdList CoreTickish
ticks) f :: FloatingBind
f@UnsafeEqualityCase{}
= (OrdList FloatingBind
flt_binds OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> a -> OrdList a
`snocOL` FloatingBind
f, OrdList CoreTickish
ticks)
go (OrdList FloatingBind
flt_binds, OrdList CoreTickish
ticks) f :: FloatingBind
f@Float{}
= (OrdList FloatingBind
flt_binds OrdList FloatingBind -> FloatingBind -> OrdList FloatingBind
forall a. OrdList a -> a -> OrdList a
`snocOL` (CoreTickish -> FloatingBind -> FloatingBind)
-> FloatingBind -> OrdList CoreTickish -> FloatingBind
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL CoreTickish -> FloatingBind -> FloatingBind
wrap FloatingBind
f OrdList CoreTickish
ticks, OrdList CoreTickish
ticks)
wrap :: CoreTickish -> FloatingBind -> FloatingBind
wrap CoreTickish
t (Float CoreBind
bind BindInfo
bound FloatInfo
info) = CoreBind -> BindInfo -> FloatInfo -> FloatingBind
Float (CoreTickish -> CoreBind -> CoreBind
wrapBind CoreTickish
t CoreBind
bind) BindInfo
bound FloatInfo
info
wrap CoreTickish
_ FloatingBind
f = String -> SDoc -> FloatingBind
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unexpected FloatingBind" (FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatingBind
f)
wrapBind :: CoreTickish -> CoreBind -> CoreBind
wrapBind CoreTickish
t (NonRec InVar
binder CpeApp
rhs) = InVar -> CpeApp -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec InVar
binder (CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
t CpeApp
rhs)
wrapBind CoreTickish
t (Rec [(InVar, CpeApp)]
pairs) = [(InVar, CpeApp)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ((CpeApp -> CpeApp) -> [(InVar, CpeApp)] -> [(InVar, CpeApp)]
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a, b) -> f (a, c)
mapSnd (CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
t) [(InVar, CpeApp)]
pairs)
cpeBigNatLit
:: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs)
cpeBigNatLit :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeApp)
cpeBigNatLit CorePrepEnv
env Integer
i = Bool -> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. HasCallStack => Bool -> a -> a
assert (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0) (UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp))
-> UniqSM (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a b. (a -> b) -> a -> b
$ do
let
platform :: Platform
platform = CorePrepConfig -> Platform
cp_platform (CorePrepEnv -> CorePrepConfig
cpe_config CorePrepEnv
env)
encodeBigNat
:: forall a. Num a => FixedPrim a -> BS.ByteString
encodeBigNat :: forall a. Num a => FixedPrim a -> ByteString
encodeBigNat FixedPrim a
encodeWord
= LazyByteString -> ByteString
BS.toStrict (Builder -> LazyByteString
BB.toLazyByteString (FixedPrim a
-> (Integer -> Maybe (a, Integer)) -> Integer -> Builder
forall b a. FixedPrim b -> (a -> Maybe (b, a)) -> a -> Builder
primUnfoldrFixed FixedPrim a
encodeWord Integer -> Maybe (a, Integer)
f Integer
i))
where
f :: Integer -> Maybe (a, Integer)
f Integer
0 = Maybe (a, Integer)
forall a. Maybe a
Nothing
f Integer
x = let low :: a
low = Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
x :: a
high :: Integer
high = Integer
x Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
bits
in (a, Integer) -> Maybe (a, Integer)
forall a. a -> Maybe a
Just (a
low, Integer
high)
bits :: Int
bits = Platform -> Int
platformWordSizeInBits Platform
platform
words :: BS.ByteString
words :: ByteString
words = case (Platform -> PlatformWordSize
platformWordSize Platform
platform, Platform -> ByteOrder
platformByteOrder Platform
platform) of
(PlatformWordSize
PW4, ByteOrder
LittleEndian) -> FixedPrim Word32 -> ByteString
forall a. Num a => FixedPrim a -> ByteString
encodeBigNat FixedPrim Word32
word32LE
(PlatformWordSize
PW4, ByteOrder
BigEndian ) -> FixedPrim Word32 -> ByteString
forall a. Num a => FixedPrim a -> ByteString
encodeBigNat FixedPrim Word32
word32BE
(PlatformWordSize
PW8, ByteOrder
LittleEndian) -> FixedPrim Word64 -> ByteString
forall a. Num a => FixedPrim a -> ByteString
encodeBigNat FixedPrim Word64
word64LE
(PlatformWordSize
PW8, ByteOrder
BigEndian ) -> FixedPrim Word64 -> ByteString
forall a. Num a => FixedPrim a -> ByteString
encodeBigNat FixedPrim Word64
word64BE
litAddrId <- FastString -> Type -> Type -> UniqSM InVar
forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m InVar
mkSysLocalM (String -> FastString
fsLit String
"bigNatGuts") Type
ManyTy Type
addrPrimTy
deadNewByteArrayTupleId
<- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $
mkTupleTy Unboxed [ realWorldStatePrimTy
, realWorldMutableByteArrayPrimTy
]
stateTokenFromNewByteArrayId
<- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy
mutableByteArrayId
<- mkSysLocalM (fsLit "mba") ManyTy realWorldMutableByteArrayPrimTy
stateTokenFromCopyId
<- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy
deadFreezeTupleId
<- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $
mkTupleTy Unboxed [realWorldStatePrimTy, byteArrayPrimTy]
stateTokenFromFreezeId
<- (`setIdOccInfo` IAmDead) <$>
mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy
byteArrayId <- mkSysLocalM (fsLit "ba") ManyTy byteArrayPrimTy
let
litAddrRhs = Literal -> Expr b
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString ByteString
words)
(litAddrFloat, litAddrId') = mkNonRecFloat env Unlifted litAddrId litAddrRhs
contentsLength = Platform -> Integer -> CpeApp
forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (ByteString -> Int
BS.length ByteString
words))
newByteArrayCall =
InVar -> CpeApp
forall b. InVar -> Expr b
Var (PrimOp -> InVar
primOpId PrimOp
NewByteArrayOp_Char)
CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CpeApp
forall b. Type -> Expr b
Type Type
realWorldTy
CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
`App` CpeApp
contentsLength
CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
`App` InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
realWorldPrimId
copyContentsCall =
InVar -> CpeApp
forall b. InVar -> Expr b
Var (PrimOp -> InVar
primOpId PrimOp
CopyAddrToByteArrayOp)
CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CpeApp
forall b. Type -> Expr b
Type Type
realWorldTy
CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
`App` InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
litAddrId'
CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
`App` InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
mutableByteArrayId
CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
`App` Platform -> Integer -> CpeApp
forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform Integer
0
CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
`App` CpeApp
contentsLength
CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
`App` InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
stateTokenFromNewByteArrayId
unsafeFreezeCall =
InVar -> CpeApp
forall b. InVar -> Expr b
Var (PrimOp -> InVar
primOpId PrimOp
UnsafeFreezeByteArrayOp)
CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CpeApp
forall b. Type -> Expr b
Type Type
realWorldTy
CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
`App` InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
mutableByteArrayId
CpeApp -> CpeApp -> CpeApp
forall b. Expr b -> Expr b -> Expr b
`App` InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
stateTokenFromCopyId
unboxed2tuple_altcon :: AltCon
unboxed2tuple_altcon = DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed Int
2)
finalRhs =
CpeApp -> InVar -> Type -> [Alt InVar] -> CpeApp
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeApp
newByteArrayCall InVar
deadNewByteArrayTupleId Type
byteArrayPrimTy
[ AltCon -> [InVar] -> CpeApp -> Alt InVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
unboxed2tuple_altcon
[InVar
stateTokenFromNewByteArrayId, InVar
mutableByteArrayId]
CpeApp
copyContentsCase
]
copyContentsCase =
CpeApp -> InVar -> Type -> [Alt InVar] -> CpeApp
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeApp
copyContentsCall InVar
stateTokenFromCopyId Type
byteArrayPrimTy
[ AltCon -> [InVar] -> CpeApp -> Alt InVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CpeApp
unsafeFreezeCase
]
unsafeFreezeCase =
CpeApp -> InVar -> Type -> [Alt InVar] -> CpeApp
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CpeApp
unsafeFreezeCall InVar
deadFreezeTupleId Type
byteArrayPrimTy
[ AltCon -> [InVar] -> CpeApp -> Alt InVar
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
unboxed2tuple_altcon
[InVar
stateTokenFromFreezeId, InVar
byteArrayId]
(InVar -> CpeApp
forall b. InVar -> Expr b
Var InVar
byteArrayId)
]
pure (emptyFloats `snocFloat` litAddrFloat, finalRhs)