{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CoreToStg.Prep
   ( corePrepPgm
   , corePrepExpr
   , mkConvertNumLiteral
   )
where
import GHC.Prelude
import GHC.Platform
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Driver.Ppr
import GHC.Tc.Utils.Env
import GHC.Unit
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Core.Utils
import GHC.Core.Opt.Arity
import GHC.Core.FVs
import GHC.Core.Opt.Monad ( CoreToDo(..) )
import GHC.Core.Lint    ( endPassIO )
import GHC.Core
import GHC.Core.Make hiding( FloatBind(..) )   
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Opt.OccurAnal
import GHC.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.Utils.Trace
import GHC.Types.Demand
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Id.Make ( realWorldPrimId )
import GHC.Types.Basic
import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName )
import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
import GHC.Types.Literal
import GHC.Types.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    
corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
            -> IO CoreProgram
corePrepPgm :: HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO CoreProgram
corePrepPgm HscEnv
hsc_env 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
text String
"CorePrep"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
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'
    CorePrepEnv
initialCorePrepEnv <- HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv HscEnv
hsc_env
    let
        implicit_binds :: CoreProgram
implicit_binds = DynFlags -> ModLocation -> [TyCon] -> CoreProgram
mkDataConWorkers DynFlags
dflags ModLocation
mod_loc [TyCon]
data_tycons
            
            
        binds_out :: CoreProgram
binds_out = UniqSupply -> UniqSM CoreProgram -> CoreProgram
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (UniqSM CoreProgram -> CoreProgram)
-> UniqSM CoreProgram -> CoreProgram
forall a b. (a -> b) -> a -> b
$ do
                      Floats
floats1 <- CorePrepEnv -> CoreProgram -> UniqSM Floats
corePrepTopBinds CorePrepEnv
initialCorePrepEnv CoreProgram
binds
                      Floats
floats2 <- CorePrepEnv -> CoreProgram -> UniqSM Floats
corePrepTopBinds CorePrepEnv
initialCorePrepEnv CoreProgram
implicit_binds
                      CoreProgram -> UniqSM CoreProgram
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats -> CoreProgram
deFloatTop (Floats
floats1 Floats -> Floats -> Floats
`appendFloats` Floats
floats2))
    HscEnv
-> PrintUnqualified
-> CoreToDo
-> CoreProgram
-> [CoreRule]
-> IO ()
endPassIO HscEnv
hsc_env PrintUnqualified
alwaysQualify CoreToDo
CorePrep CoreProgram
binds_out []
    CoreProgram -> IO CoreProgram
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreProgram
binds_out
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr :: HscEnv -> CpeApp -> IO CpeApp
corePrepExpr HscEnv
hsc_env CpeApp
expr = do
    let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    Logger -> SDoc -> (CpeApp -> ()) -> IO CpeApp -> IO CpeApp
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
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'
      CorePrepEnv
initialCorePrepEnv <- HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv HscEnv
hsc_env
      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 :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> CoreProgram
mkDataConWorkers DynFlags
dflags 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 (DynFlags -> Bool
needSourceNotes DynFlags
dflags)           = 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 (RealSrcSpan -> String -> CoreTickish
forall (pass :: TickishPass).
RealSrcSpan -> String -> GenTickish pass
SourceNote RealSrcSpan
span (String -> CoreTickish) -> String -> CoreTickish
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name))
           span1 :: String -> RealSrcSpan
span1 String
file = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
file) Int
1 Int
1
cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
        -> UniqSM (CorePrepEnv,
                   Floats,         
                   Maybe CoreBind) 
                                   
cpeBind :: TopLevelFlag
-> CorePrepEnv
-> CoreBind
-> UniqSM (CorePrepEnv, Floats, Maybe CoreBind)
cpeBind TopLevelFlag
top_lvl CorePrepEnv
env (NonRec Id
bndr 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 CorePrepEnv -> LitNumType -> Integer -> Maybe CpeApp
cpe_convertNumLit 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
floatableTick 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'
                 
                 
                 
                 
                 
                 
               | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CatchNonexhaustiveCases (CorePrepEnv -> DynFlags
cpe_dynFlags 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 = Id -> Type -> String -> CpeApp
mkRuntimeErrorApp Id
rUNTIME_ERROR_ID Type
ty
                                             String
"Bottoming expression returned"
       ; [Alt Id]
alts'' <- (Alt Id -> UniqSM (Alt Id)) -> [Alt Id] -> UniqSM [Alt Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
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 {})
  | Just CpeApp
no_lam_result <- [Id] -> CpeApp -> Maybe CpeApp
tryEtaReducePrep [Id]
bndrs CpeApp
body
  = (Floats, CpeApp) -> UniqSM (Floats, CpeApp)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Floats
emptyFloats, CpeApp
no_lam_result)
  | (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
body) = 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
text String
"app" SDoc -> SDoc -> SDoc
<+> CpeApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeApp
arg
  ppr (CpeCast Coercion
co) = String -> SDoc
text String
"cast" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
  ppr (CpeTick CoreTickish
tick) = String -> SDoc
text String
"tick" SDoc -> SDoc -> SDoc
<+> CoreTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreTickish
tick
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeApp :: CorePrepEnv -> 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
            
            
            
            | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
floatableTick CoreTickish
tickish Bool -> Bool -> Bool
|| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
isProfTick CoreTickish
tickish
            , Var Id
vh <- CpeApp
head
            , Var Id
head' <- CorePrepEnv -> Id -> CpeApp
lookupCorePrepEnv CorePrepEnv
top_env Id
vh
            , Id -> Bool
hasNoBinding Id
head'
            = (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      
            
        
        
        
        
        
        
        
        
        
        
        
        
        
        = 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
floatableTick 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 [Demand]
ss' [CoreTickish]
rt_ticks Int
req_depth
        where
            co' :: Coercion
co' = CorePrepEnv -> Coercion -> Coercion
cpSubstCo CorePrepEnv
env Coercion
co
            ss' :: [Demand]
ss'
              | [Demand] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Demand]
ss = []
              | Bool
otherwise = [Demand] -> [Demand]
forall a. HasCallStack => [a] -> [a]
tail [Demand]
ss
      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
$$ String -> SDoc
text String
"expr:" SDoc -> SDoc -> SDoc
<+> CpeApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeApp
expr SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"n_args:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n_args SDoc -> SDoc -> SDoc
$$
          String -> SDoc
text String
"marks:" SDoc -> SDoc -> SDoc
<+> Maybe [CbvMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Maybe [CbvMark]
idCbvMarks_maybe Id
fn) SDoc -> SDoc -> SDoc
$$
          String -> SDoc
text String
"join_arity" SDoc -> SDoc -> SDoc
<+> Maybe Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Maybe Int
isJoinId_maybe Id
fn) SDoc -> SDoc -> SDoc
$$
          String -> SDoc
text String
"fn_arity" SDoc -> SDoc -> SDoc
<+> 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
tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
tryEtaReducePrep :: [Id] -> CpeApp -> Maybe CpeApp
tryEtaReducePrep [Id]
bndrs expr :: CpeApp
expr@(App CpeApp
_ CpeApp
_)
  | CpeApp -> Bool
ok_to_eta_reduce CpeApp
f
  , Int
n_remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
  , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Id -> CpeApp -> Bool) -> [Id] -> [CpeApp] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Id -> CpeApp -> Bool
forall {b}. Id -> Expr b -> Bool
ok [Id]
bndrs [CpeApp]
last_args)
  , Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> VarSet -> Bool
`elemVarSet` VarSet
fvs_remaining) [Id]
bndrs)
  , CpeApp -> Bool
exprIsHNF CpeApp
remaining_expr   
                               
  =
    
    
    
    
    CpeApp -> Maybe CpeApp
forall a. a -> Maybe a
Just CpeApp
remaining_expr
  where
    (CpeApp
f, [CpeApp]
args) = CpeApp -> (CpeApp, [CpeApp])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CpeApp
expr
    remaining_expr :: CpeApp
remaining_expr = CpeApp -> [CpeApp] -> CpeApp
forall b. Expr b -> [Expr b] -> Expr b
mkApps CpeApp
f [CpeApp]
remaining_args
    fvs_remaining :: VarSet
fvs_remaining = CpeApp -> VarSet
exprFreeVars CpeApp
remaining_expr
    ([CpeApp]
remaining_args, [CpeApp]
last_args) = Int -> [CpeApp] -> ([CpeApp], [CpeApp])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_remaining [CpeApp]
args
    n_remaining :: Int
n_remaining = [CpeApp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CpeApp]
args Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
bndrs
    n_remaining_vals :: Int
n_remaining_vals = [CpeApp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([CpeApp] -> Int) -> [CpeApp] -> Int
forall a b. (a -> b) -> a -> b
$ (CpeApp -> Bool) -> [CpeApp] -> [CpeApp]
forall a. (a -> Bool) -> [a] -> [a]
filter CpeApp -> Bool
isRuntimeArg [CpeApp]
remaining_args
    ok :: Id -> Expr b -> Bool
ok Id
bndr (Var Id
arg) = Id
bndr Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
arg
    ok Id
_    Expr b
_         = Bool
False
    ok_to_eta_reduce :: CpeApp -> Bool
ok_to_eta_reduce (Var Id
f) = Id -> Int -> Int -> Bool
canEtaReduceToArity Id
f Int
n_remaining Int
n_remaining_vals
    ok_to_eta_reduce CpeApp
_       = Bool
False 
tryEtaReducePrep [Id]
bndrs (Tick CoreTickish
tickish CpeApp
e)
  | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
tickish
  = (CpeApp -> CpeApp) -> Maybe CpeApp -> Maybe CpeApp
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
tickish) (Maybe CpeApp -> Maybe CpeApp) -> Maybe CpeApp -> Maybe CpeApp
forall a b. (a -> b) -> a -> b
$ [Id] -> CpeApp -> Maybe CpeApp
tryEtaReducePrep [Id]
bndrs CpeApp
e
tryEtaReducePrep [Id]
_ CpeApp
_ = Maybe CpeApp
forall a. Maybe a
Nothing
data FloatingBind
  = FloatLet CoreBind    
                         
                         
 | FloatCase
      CpeBody         
      Id              
      AltCon [Var]    
      Bool            
                      
 
 | FloatTick CoreTickish
data Floats = Floats OkToSpec (OrdList FloatingBind)
instance Outputable FloatingBind where
  ppr :: FloatingBind -> SDoc
ppr (FloatLet CoreBind
b) = CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
b
  ppr (FloatCase CpeApp
r Id
b AltCon
k [Id]
bs Bool
ok) = String -> SDoc
text String
"case" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
ok) SDoc -> SDoc -> SDoc
<+> CpeApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr CpeApp
r
                                SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"of"SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"@"
                                SDoc -> SDoc -> SDoc
<> case [Id]
bs of
                                   [] -> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
k
                                   [Id]
_  -> SDoc -> SDoc
parens (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
k SDoc -> SDoc -> SDoc
<+> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
bs)
  ppr (FloatTick CoreTickish
t) = CoreTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreTickish
t
instance Outputable Floats where
  ppr :: Floats -> SDoc
ppr (Floats OkToSpec
flag OrdList FloatingBind
fs) = String -> SDoc
text String
"Floats" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (OkToSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr OkToSpec
flag) SDoc -> SDoc -> SDoc
<+>
                         SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat ((FloatingBind -> SDoc) -> [FloatingBind] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FloatingBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OrdList FloatingBind -> [FloatingBind]
forall a. OrdList a -> [a]
fromOL OrdList FloatingBind
fs)))
instance Outputable OkToSpec where
  ppr :: OkToSpec -> SDoc
ppr OkToSpec
OkToSpec    = String -> SDoc
text String
"OkToSpec"
  ppr OkToSpec
IfUnboxedOk = String -> SDoc
text String
"IfUnboxedOk"
  ppr OkToSpec
NotOkToSpec = String -> SDoc
text String
"NotOkToSpec"
data OkToSpec
   = OkToSpec           
   | IfUnboxedOk        
                        
   | NotOkToSpec        
mkFloat :: 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 CorePrepEnv
  = CPE { CorePrepEnv -> DynFlags
cpe_dynFlags        :: DynFlags
        , CorePrepEnv -> IdEnv CpeApp
cpe_env             :: IdEnv CoreExpr   
        
        
        
        
        
        
        
        
        
        
        
        , CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env :: Maybe CpeTyCoEnv 
        , CorePrepEnv -> LitNumType -> Integer -> Maybe CpeApp
cpe_convertNumLit   :: LitNumType -> Integer -> Maybe CoreExpr
        
        
        , CorePrepEnv -> UnVarSet
cpe_rec_ids         :: UnVarSet 
    }
mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv HscEnv
hsc_env = do
   LitNumType -> Integer -> Maybe CpeApp
convertNumLit <- HscEnv -> IO (LitNumType -> Integer -> Maybe CpeApp)
mkConvertNumLiteral HscEnv
hsc_env
   CorePrepEnv -> IO CorePrepEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CorePrepEnv -> IO CorePrepEnv) -> CorePrepEnv -> IO CorePrepEnv
forall a b. (a -> b) -> a -> b
$ CPE
      { cpe_dynFlags :: DynFlags
cpe_dynFlags      = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      , 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_convertNumLit :: LitNumType -> Integer -> Maybe CpeApp
cpe_convertNumLit = LitNumType -> Integer -> Maybe CpeApp
convertNumLit
      , 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 :: IdEnv CpeApp
cpe_env = IdEnv CpeApp -> Id -> CpeApp -> IdEnv CpeApp
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (CorePrepEnv -> IdEnv CpeApp
cpe_env CorePrepEnv
cpe) Id
id (Id -> CpeApp
forall b. Id -> Expr b
Var Id
id') }
extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CpeApp -> CorePrepEnv
extendCorePrepEnvExpr CorePrepEnv
cpe Id
id CpeApp
expr
    = CorePrepEnv
cpe { cpe_env :: IdEnv CpeApp
cpe_env = IdEnv CpeApp -> Id -> CpeApp -> IdEnv CpeApp
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (CorePrepEnv -> IdEnv CpeApp
cpe_env CorePrepEnv
cpe) Id
id CpeApp
expr }
extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
extendCorePrepEnvList :: CorePrepEnv -> [(Id, Id)] -> CorePrepEnv
extendCorePrepEnvList CorePrepEnv
cpe [(Id, Id)]
prs
    = CorePrepEnv
cpe { cpe_env :: IdEnv CpeApp
cpe_env = IdEnv CpeApp -> [(Id, CpeApp)] -> IdEnv CpeApp
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList (CorePrepEnv -> IdEnv CpeApp
cpe_env CorePrepEnv
cpe)
                        (((Id, Id) -> (Id, CpeApp)) -> [(Id, Id)] -> [(Id, CpeApp)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
id, Id
id') -> (Id
id, Id -> CpeApp
forall b. Id -> Expr b
Var Id
id')) [(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 :: UnVarSet
cpe_rec_ids = [Id] -> UnVarSet -> UnVarSet
extendUnVarSetList [Id]
grp (CorePrepEnv -> UnVarSet
cpe_rec_ids CorePrepEnv
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 :: Maybe CpeTyCoEnv
cpe_tyco_env = CpeTyCoEnv -> Maybe CpeTyCoEnv
forall a. a -> Maybe a
Just (CpeTyCoEnv -> Id -> Coercion -> CpeTyCoEnv
extend_tce_cv CpeTyCoEnv
tce Id
cv Coercion
co) }
  where
    tce :: CpeTyCoEnv
tce = Maybe CpeTyCoEnv
mb_tce Maybe CpeTyCoEnv -> CpeTyCoEnv -> CpeTyCoEnv
forall a. Maybe a -> a -> a
`orElse` CpeTyCoEnv
emptyTCE
cpSubstTy :: CorePrepEnv -> Type -> Type
cpSubstTy :: CorePrepEnv -> Type -> Type
cpSubstTy (CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_env }) Type
ty
  = case Maybe CpeTyCoEnv
mb_env of
      Just CpeTyCoEnv
env -> Identity Type -> Type
forall a. Identity a -> a
runIdentity (CpeTyCoEnv -> Type -> Identity Type
subst_ty CpeTyCoEnv
env Type
ty)
      Maybe CpeTyCoEnv
Nothing  -> Type
ty
cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
cpSubstCo (CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_env }) Coercion
co
  = case Maybe CpeTyCoEnv
mb_env of
      Just CpeTyCoEnv
tce -> Identity Coercion -> Coercion
forall a. Identity a -> a
runIdentity (CpeTyCoEnv -> Coercion -> Identity Coercion
subst_co CpeTyCoEnv
tce Coercion
co)
      Maybe CpeTyCoEnv
Nothing  -> Coercion
co
subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity
subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity
subst_tyco_mapper = TyCoMapper
  { 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 -> ArgFlag -> Identity (CpeTyCoEnv, Id)
tcm_tycobinder = \CpeTyCoEnv
env Id
tcv ArgFlag
_vis -> if Id -> Bool
isTyVar Id
tcv
                                      then (CpeTyCoEnv, Id) -> Identity (CpeTyCoEnv, Id)
forall 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 :: Maybe CpeTyCoEnv
cpe_tyco_env = CpeTyCoEnv -> Maybe CpeTyCoEnv
forall a. a -> Maybe a
Just CpeTyCoEnv
tce' }, Id
tv')
               where
                  (CpeTyCoEnv
tce', Id
tv') = CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_tv_bndr CpeTyCoEnv
tce Id
tv
subst_tv_bndr :: CpeTyCoEnv -> TyVar -> (CpeTyCoEnv, TyVar)
subst_tv_bndr :: CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_tv_bndr CpeTyCoEnv
tce Id
tv
  = (CpeTyCoEnv -> Id -> Type -> CpeTyCoEnv
extend_tce_tv CpeTyCoEnv
tce Id
tv (Id -> Type
mkTyVarTy Id
tv'), Id
tv')
  where
    tv' :: Id
tv'   = Name -> Type -> Id
mkTyVar (Id -> Name
tyVarName Id
tv) Type
kind'
    kind' :: Type
kind' = Identity Type -> Type
forall a. Identity a -> a
runIdentity (Identity Type -> Type) -> Identity Type -> Type
forall a b. (a -> b) -> a -> b
$ CpeTyCoEnv -> Type -> Identity Type
subst_ty CpeTyCoEnv
tce (Type -> Identity Type) -> Type -> Identity Type
forall a b. (a -> b) -> a -> b
$ Id -> Type
tyVarKind Id
tv
cpSubstCoVarBndr :: CorePrepEnv -> CoVar -> (CorePrepEnv, CoVar)
cpSubstCoVarBndr :: CorePrepEnv -> Id -> (CorePrepEnv, Id)
cpSubstCoVarBndr env :: CorePrepEnv
env@(CPE { cpe_tyco_env :: CorePrepEnv -> Maybe CpeTyCoEnv
cpe_tyco_env = Maybe CpeTyCoEnv
mb_env }) Id
cv
  = case Maybe CpeTyCoEnv
mb_env of
      Maybe CpeTyCoEnv
Nothing  -> (CorePrepEnv
env, Id
cv)
      Just CpeTyCoEnv
tce -> (CorePrepEnv
env { cpe_tyco_env :: Maybe CpeTyCoEnv
cpe_tyco_env = CpeTyCoEnv -> Maybe CpeTyCoEnv
forall a. a -> Maybe a
Just CpeTyCoEnv
tce' }, Id
cv')
               where
                  (CpeTyCoEnv
tce', Id
cv') = CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_cv_bndr CpeTyCoEnv
tce Id
cv
subst_cv_bndr :: CpeTyCoEnv -> CoVar -> (CpeTyCoEnv, CoVar)
subst_cv_bndr :: CpeTyCoEnv -> Id -> (CpeTyCoEnv, Id)
subst_cv_bndr CpeTyCoEnv
tce Id
cv
  = (CpeTyCoEnv -> Id -> Coercion -> CpeTyCoEnv
extend_tce_cv CpeTyCoEnv
tce Id
cv (Id -> Coercion
mkCoVarCo Id
cv'), Id
cv')
  where
    cv' :: Id
cv' = Name -> Type -> Id
mkCoVar (Id -> Name
varName Id
cv) Type
ty'
    ty' :: Type
ty' = Identity Type -> Type
forall a. Identity a -> a
runIdentity (CpeTyCoEnv -> Type -> Identity Type
subst_ty CpeTyCoEnv
tce (Type -> Identity Type) -> Type -> Identity Type
forall a b. (a -> b) -> a -> b
$ Id -> Type
varType Id
cv)
cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
cpCloneBndrs :: CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
cpCloneBndrs CorePrepEnv
env [Id]
bs = (CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id))
-> CorePrepEnv -> [Id] -> UniqSM (CorePrepEnv, [Id])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env [Id]
bs
cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
cpCloneBndr :: CorePrepEnv -> Id -> UniqSM (CorePrepEnv, Id)
cpCloneBndr CorePrepEnv
env Id
bndr
  | Id -> Bool
isTyVar Id
bndr
  = (CorePrepEnv, Id) -> UniqSM (CorePrepEnv, Id)
forall 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` do
     Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
     Id -> UniqSM Id
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> Unique -> Type -> Type -> Id
mkSysLocalOrCoVar (String -> FastString
fsLit String
"sat") Unique
uniq Type
Many Type
ty)
wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
wrapTicks :: Floats -> 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 b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd (CoreTickish -> CpeApp -> CpeApp
mkTick CoreTickish
t) [(Id, CpeApp)]
pairs)
floatableTick :: GenTickish pass -> Bool
floatableTick :: forall (pass :: TickishPass). GenTickish pass -> Bool
floatableTick GenTickish pass
tickish =
    GenTickish pass -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace GenTickish pass
tickish TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceNonLam Bool -> Bool -> Bool
&&
    GenTickish pass
tickish GenTickish pass -> TickishScoping -> Bool
forall (pass :: TickishPass).
GenTickish pass -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
mkConvertNumLiteral
   :: HscEnv
   -> IO (LitNumType -> Integer -> Maybe CoreExpr)
mkConvertNumLiteral :: HscEnv -> IO (LitNumType -> Integer -> Maybe CpeApp)
mkConvertNumLiteral HscEnv
hsc_env = do
   let
      dflags :: DynFlags
dflags   = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
      home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
      guardBignum :: IO Id -> IO Id
guardBignum IO Id
act
         | HomeUnit -> UnitId -> Bool
isHomeUnitInstanceOf HomeUnit
home_unit UnitId
primUnitId
         = Id -> IO Id
forall 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. 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. 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
<$> HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env 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
            target :: Platform
target    = DynFlags -> Platform
targetPlatform DynFlags
dflags
            
            
            
            
            
            
            
            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
target
                  mask :: Integer
mask = Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
bits Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
         in 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