{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.SpecConstr(
specConstrProgram,
SpecConstrAnnotation(..)
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Core
import GHC.Core.Subst
import GHC.Core.Utils
import GHC.Core.Unfold
import GHC.Core.FVs ( exprsFreeVarsList )
import GHC.Core.Opt.Monad
import GHC.Types.Literal ( litIsLifted )
import GHC.Unit.Module.ModGuts
import GHC.Core.Opt.WorkWrap.Utils ( isWorkerSmallEnough, mkWorkerArgs )
import GHC.Core.DataCon
import GHC.Core.Coercion hiding( substCo )
import GHC.Core.Rules
import GHC.Core.Type hiding ( substTy )
import GHC.Core.TyCon (TyCon, tyConUnique, tyConName )
import GHC.Core.Multiplicity
import GHC.Types.Id
import GHC.Core.Ppr ( pprParendExpr )
import GHC.Core.Make ( mkImpossibleExpr )
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Tickish
import GHC.Types.Basic
import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )
, gopt, hasPprDebug )
import GHC.Driver.Ppr
import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing )
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Serialized ( deserializeWithData )
import GHC.Utils.Misc
import GHC.Data.Pair
import GHC.Types.Unique.Supply
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Types.Unique.FM
import GHC.Utils.Monad
import Control.Monad ( zipWithM )
import Data.List (nubBy, sortBy, partition)
import GHC.Builtin.Names ( specTyConKey )
import GHC.Unit.Module
import GHC.Exts( SpecConstrAnnotation(..) )
import Data.Ord( comparing )
specConstrProgram :: ModGuts -> CoreM ModGuts
specConstrProgram :: ModGuts -> CoreM ModGuts
specConstrProgram ModGuts
guts
= do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
UniqSupply
us <- forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
(ModuleEnv SpecConstrAnnotation
_, NameEnv SpecConstrAnnotation
annos) <- forall a.
Typeable a =>
([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)
getFirstAnnotations forall a. Data a => [Word8] -> a
deserializeWithData ModGuts
guts
Module
this_mod <- forall (m :: * -> *). HasModule m => m Module
getModule
let binds' :: [CoreBind]
binds' = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
us forall a b. (a -> b) -> a -> b
$ do
(ScEnv
env, [CoreBind]
binds) <- ScEnv -> [CoreBind] -> UniqSM (ScEnv, [CoreBind])
goEnv (DynFlags -> Module -> NameEnv SpecConstrAnnotation -> ScEnv
initScEnv DynFlags
dflags Module
this_mod NameEnv SpecConstrAnnotation
annos)
(ModGuts -> [CoreBind]
mg_binds ModGuts
guts)
ScEnv -> ScUsage -> [CoreBind] -> UniqSM [CoreBind]
go ScEnv
env ScUsage
nullUsage (forall a. [a] -> [a]
reverse [CoreBind]
binds)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModGuts
guts { mg_binds :: [CoreBind]
mg_binds = [CoreBind]
binds' })
where
goEnv :: ScEnv -> [CoreBind] -> UniqSM (ScEnv, [CoreBind])
goEnv ScEnv
env [] = forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv
env, [])
goEnv ScEnv
env (CoreBind
bind:[CoreBind]
binds) = do (ScEnv
env', CoreBind
bind') <- ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
scTopBindEnv ScEnv
env CoreBind
bind
(ScEnv
env'', [CoreBind]
binds') <- ScEnv -> [CoreBind] -> UniqSM (ScEnv, [CoreBind])
goEnv ScEnv
env' [CoreBind]
binds
forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv
env'', CoreBind
bind' forall a. a -> [a] -> [a]
: [CoreBind]
binds')
go :: ScEnv -> ScUsage -> [CoreBind] -> UniqSM [CoreBind]
go ScEnv
_ ScUsage
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
go ScEnv
env ScUsage
usg (CoreBind
bind:[CoreBind]
binds) = do (ScUsage
usg', CoreBind
bind') <- ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
scTopBind ScEnv
env ScUsage
usg CoreBind
bind
[CoreBind]
binds' <- ScEnv -> ScUsage -> [CoreBind] -> UniqSM [CoreBind]
go ScEnv
env ScUsage
usg' [CoreBind]
binds
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind
bind' forall a. a -> [a] -> [a]
: [CoreBind]
binds')
data ScEnv = SCE { ScEnv -> DynFlags
sc_dflags :: DynFlags,
ScEnv -> UnfoldingOpts
sc_uf_opts :: !UnfoldingOpts,
ScEnv -> Module
sc_module :: !Module,
ScEnv -> Maybe Int
sc_size :: Maybe Int,
ScEnv -> Maybe Int
sc_count :: Maybe Int,
ScEnv -> Int
sc_recursive :: Int,
ScEnv -> Bool
sc_keen :: Bool,
ScEnv -> Bool
sc_force :: Bool,
ScEnv -> Subst
sc_subst :: Subst,
ScEnv -> HowBoundEnv
sc_how_bound :: HowBoundEnv,
ScEnv -> ValueEnv
sc_vals :: ValueEnv,
ScEnv -> NameEnv SpecConstrAnnotation
sc_annotations :: UniqFM Name SpecConstrAnnotation
}
type HowBoundEnv = VarEnv HowBound
type ValueEnv = IdEnv Value
data Value = ConVal AltCon [CoreArg]
| LambdaVal
instance Outputable Value where
ppr :: Value -> SDoc
ppr (ConVal AltCon
con [Expr Id]
args) = forall a. Outputable a => a -> SDoc
ppr AltCon
con SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => [a] -> SDoc
interpp'SP [Expr Id]
args
ppr Value
LambdaVal = String -> SDoc
text String
"<Lambda>"
initScEnv :: DynFlags -> Module -> UniqFM Name SpecConstrAnnotation -> ScEnv
initScEnv :: DynFlags -> Module -> NameEnv SpecConstrAnnotation -> ScEnv
initScEnv DynFlags
dflags Module
this_mod NameEnv SpecConstrAnnotation
anns
= SCE { sc_dflags :: DynFlags
sc_dflags = DynFlags
dflags,
sc_uf_opts :: UnfoldingOpts
sc_uf_opts = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags,
sc_module :: Module
sc_module = Module
this_mod,
sc_size :: Maybe Int
sc_size = DynFlags -> Maybe Int
specConstrThreshold DynFlags
dflags,
sc_count :: Maybe Int
sc_count = DynFlags -> Maybe Int
specConstrCount DynFlags
dflags,
sc_recursive :: Int
sc_recursive = DynFlags -> Int
specConstrRecursive DynFlags
dflags,
sc_keen :: Bool
sc_keen = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SpecConstrKeen DynFlags
dflags,
sc_force :: Bool
sc_force = Bool
False,
sc_subst :: Subst
sc_subst = Subst
emptySubst,
sc_how_bound :: HowBoundEnv
sc_how_bound = forall a. VarEnv a
emptyVarEnv,
sc_vals :: ValueEnv
sc_vals = forall a. VarEnv a
emptyVarEnv,
sc_annotations :: NameEnv SpecConstrAnnotation
sc_annotations = NameEnv SpecConstrAnnotation
anns }
data HowBound = RecFun
| RecArg
instance Outputable HowBound where
ppr :: HowBound -> SDoc
ppr HowBound
RecFun = String -> SDoc
text String
"RecFun"
ppr HowBound
RecArg = String -> SDoc
text String
"RecArg"
scForce :: ScEnv -> Bool -> ScEnv
scForce :: ScEnv -> Bool -> ScEnv
scForce ScEnv
env Bool
b = ScEnv
env { sc_force :: Bool
sc_force = Bool
b }
lookupHowBound :: ScEnv -> Id -> Maybe HowBound
lookupHowBound :: ScEnv -> Id -> Maybe HowBound
lookupHowBound ScEnv
env Id
id = forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (ScEnv -> HowBoundEnv
sc_how_bound ScEnv
env) Id
id
scSubstId :: ScEnv -> Id -> CoreExpr
scSubstId :: ScEnv -> Id -> Expr Id
scSubstId ScEnv
env Id
v = HasDebugCallStack => Subst -> Id -> Expr Id
lookupIdSubst (ScEnv -> Subst
sc_subst ScEnv
env) Id
v
scSubstTy :: ScEnv -> Type -> Type
scSubstTy :: ScEnv -> Type -> Type
scSubstTy ScEnv
env Type
ty = Subst -> Type -> Type
substTy (ScEnv -> Subst
sc_subst ScEnv
env) Type
ty
scSubstCo :: ScEnv -> Coercion -> Coercion
scSubstCo :: ScEnv -> Coercion -> Coercion
scSubstCo ScEnv
env Coercion
co = HasCallStack => Subst -> Coercion -> Coercion
substCo (ScEnv -> Subst
sc_subst ScEnv
env) Coercion
co
zapScSubst :: ScEnv -> ScEnv
zapScSubst :: ScEnv -> ScEnv
zapScSubst ScEnv
env = ScEnv
env { sc_subst :: Subst
sc_subst = Subst -> Subst
zapSubstEnv (ScEnv -> Subst
sc_subst ScEnv
env) }
extendScInScope :: ScEnv -> [Var] -> ScEnv
extendScInScope :: ScEnv -> [Id] -> ScEnv
extendScInScope ScEnv
env [Id]
qvars = ScEnv
env { sc_subst :: Subst
sc_subst = Subst -> [Id] -> Subst
extendInScopeList (ScEnv -> Subst
sc_subst ScEnv
env) [Id]
qvars }
extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
extendScSubst :: ScEnv -> Id -> Expr Id -> ScEnv
extendScSubst ScEnv
env Id
var Expr Id
expr = ScEnv
env { sc_subst :: Subst
sc_subst = Subst -> Id -> Expr Id -> Subst
extendSubst (ScEnv -> Subst
sc_subst ScEnv
env) Id
var Expr Id
expr }
extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
extendScSubstList :: ScEnv -> [(Id, Expr Id)] -> ScEnv
extendScSubstList ScEnv
env [(Id, Expr Id)]
prs = ScEnv
env { sc_subst :: Subst
sc_subst = Subst -> [(Id, Expr Id)] -> Subst
extendSubstList (ScEnv -> Subst
sc_subst ScEnv
env) [(Id, Expr Id)]
prs }
extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
extendHowBound :: ScEnv -> [Id] -> HowBound -> ScEnv
extendHowBound ScEnv
env [Id]
bndrs HowBound
how_bound
= ScEnv
env { sc_how_bound :: HowBoundEnv
sc_how_bound = forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList (ScEnv -> HowBoundEnv
sc_how_bound ScEnv
env)
[(Id
bndr,HowBound
how_bound) | Id
bndr <- [Id]
bndrs] }
extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
extendBndrsWith :: HowBound -> ScEnv -> [Id] -> (ScEnv, [Id])
extendBndrsWith HowBound
how_bound ScEnv
env [Id]
bndrs
= (ScEnv
env { sc_subst :: Subst
sc_subst = Subst
subst', sc_how_bound :: HowBoundEnv
sc_how_bound = HowBoundEnv
hb_env' }, [Id]
bndrs')
where
(Subst
subst', [Id]
bndrs') = Subst -> [Id] -> (Subst, [Id])
substBndrs (ScEnv -> Subst
sc_subst ScEnv
env) [Id]
bndrs
hb_env' :: HowBoundEnv
hb_env' = ScEnv -> HowBoundEnv
sc_how_bound ScEnv
env forall a. VarEnv a -> [(Id, a)] -> VarEnv a
`extendVarEnvList`
[(Id
bndr,HowBound
how_bound) | Id
bndr <- [Id]
bndrs']
extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
extendBndrWith :: HowBound -> ScEnv -> Id -> (ScEnv, Id)
extendBndrWith HowBound
how_bound ScEnv
env Id
bndr
= (ScEnv
env { sc_subst :: Subst
sc_subst = Subst
subst', sc_how_bound :: HowBoundEnv
sc_how_bound = HowBoundEnv
hb_env' }, Id
bndr')
where
(Subst
subst', Id
bndr') = Subst -> Id -> (Subst, Id)
substBndr (ScEnv -> Subst
sc_subst ScEnv
env) Id
bndr
hb_env' :: HowBoundEnv
hb_env' = forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (ScEnv -> HowBoundEnv
sc_how_bound ScEnv
env) Id
bndr' HowBound
how_bound
extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
extendRecBndrs :: ScEnv -> [Id] -> (ScEnv, [Id])
extendRecBndrs ScEnv
env [Id]
bndrs = (ScEnv
env { sc_subst :: Subst
sc_subst = Subst
subst' }, [Id]
bndrs')
where
(Subst
subst', [Id]
bndrs') = Subst -> [Id] -> (Subst, [Id])
substRecBndrs (ScEnv -> Subst
sc_subst ScEnv
env) [Id]
bndrs
extendBndr :: ScEnv -> Var -> (ScEnv, Var)
extendBndr :: ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env Id
bndr = (ScEnv
env { sc_subst :: Subst
sc_subst = Subst
subst' }, Id
bndr')
where
(Subst
subst', Id
bndr') = Subst -> Id -> (Subst, Id)
substBndr (ScEnv -> Subst
sc_subst ScEnv
env) Id
bndr
extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv ScEnv
env Id
_ Maybe Value
Nothing = ScEnv
env
extendValEnv ScEnv
env Id
id (Just Value
cv)
| Value -> Bool
valueIsWorkFree Value
cv
= ScEnv
env { sc_vals :: ValueEnv
sc_vals = forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (ScEnv -> ValueEnv
sc_vals ScEnv
env) Id
id Value
cv }
extendValEnv ScEnv
env Id
_ Maybe Value
_ = ScEnv
env
extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])
extendCaseBndrs :: ScEnv -> Expr Id -> Id -> AltCon -> [Id] -> (ScEnv, [Id])
extendCaseBndrs ScEnv
env Expr Id
scrut Id
case_bndr AltCon
con [Id]
alt_bndrs
= (ScEnv
env2, [Id]
alt_bndrs')
where
live_case_bndr :: Bool
live_case_bndr = Bool -> Bool
not (Id -> Bool
isDeadBinder Id
case_bndr)
env1 :: ScEnv
env1 | Var Id
v <- forall b. (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksTopE (forall a b. a -> b -> a
const Bool
True) Expr Id
scrut
= ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv ScEnv
env Id
v Maybe Value
cval
| Bool
otherwise = ScEnv
env
env2 :: ScEnv
env2 | Bool
live_case_bndr = ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv ScEnv
env1 Id
case_bndr Maybe Value
cval
| Bool
otherwise = ScEnv
env1
alt_bndrs' :: [Id]
alt_bndrs' | case Expr Id
scrut of { Var {} -> Bool
True; Expr Id
_ -> Bool
live_case_bndr }
= forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
zap [Id]
alt_bndrs
| Bool
otherwise
= [Id]
alt_bndrs
cval :: Maybe Value
cval = case AltCon
con of
AltCon
DEFAULT -> forall a. Maybe a
Nothing
LitAlt {} -> forall a. a -> Maybe a
Just (AltCon -> [Expr Id] -> Value
ConVal AltCon
con [])
DataAlt {} -> forall a. a -> Maybe a
Just (AltCon -> [Expr Id] -> Value
ConVal AltCon
con [Expr Id]
vanilla_args)
where
vanilla_args :: [Expr Id]
vanilla_args = forall a b. (a -> b) -> [a] -> [b]
map forall b. Type -> Expr b
Type (Type -> [Type]
tyConAppArgs (Id -> Type
idType Id
case_bndr)) forall a. [a] -> [a] -> [a]
++
forall b. [Id] -> [Expr b]
varsToCoreExprs [Id]
alt_bndrs
zap :: Id -> Id
zap Id
v | Id -> Bool
isTyVar Id
v = Id
v
| Bool
otherwise = Id -> Id
zapIdOccInfo Id
v
decreaseSpecCount :: ScEnv -> Int -> ScEnv
decreaseSpecCount :: ScEnv -> Int -> ScEnv
decreaseSpecCount ScEnv
env Int
n_specs
= ScEnv
env { sc_force :: Bool
sc_force = Bool
False
, sc_count :: Maybe Int
sc_count = case ScEnv -> Maybe Int
sc_count ScEnv
env of
Maybe Int
Nothing -> forall a. Maybe a
Nothing
Just Int
n -> forall a. a -> Maybe a
Just (Int
n forall a. Integral a => a -> a -> a
`div` (Int
n_specs forall a. Num a => a -> a -> a
+ Int
1)) }
ignoreType :: ScEnv -> Type -> Bool
ignoreDataCon :: ScEnv -> DataCon -> Bool
forceSpecBndr :: ScEnv -> Var -> Bool
ignoreDataCon :: ScEnv -> DataCon -> Bool
ignoreDataCon ScEnv
env DataCon
dc = ScEnv -> TyCon -> Bool
ignoreTyCon ScEnv
env (DataCon -> TyCon
dataConTyCon DataCon
dc)
ignoreType :: ScEnv -> Type -> Bool
ignoreType ScEnv
env Type
ty
= case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty of
Just TyCon
tycon -> ScEnv -> TyCon -> Bool
ignoreTyCon ScEnv
env TyCon
tycon
Maybe TyCon
_ -> Bool
False
ignoreTyCon :: ScEnv -> TyCon -> Bool
ignoreTyCon :: ScEnv -> TyCon -> Bool
ignoreTyCon ScEnv
env TyCon
tycon
= forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (ScEnv -> NameEnv SpecConstrAnnotation
sc_annotations ScEnv
env) (TyCon -> Name
tyConName TyCon
tycon) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just SpecConstrAnnotation
NoSpecConstr
forceSpecBndr :: ScEnv -> Id -> Bool
forceSpecBndr ScEnv
env Id
var = ScEnv -> Type -> Bool
forceSpecFunTy ScEnv
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Id], Type)
splitForAllTyCoVars forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
varType forall a b. (a -> b) -> a -> b
$ Id
var
forceSpecFunTy :: ScEnv -> Type -> Bool
forceSpecFunTy :: ScEnv -> Type -> Bool
forceSpecFunTy ScEnv
env = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ScEnv -> Type -> Bool
forceSpecArgTy ScEnv
env) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Scaled Type], Type)
splitFunTys
forceSpecArgTy :: ScEnv -> Type -> Bool
forceSpecArgTy :: ScEnv -> Type -> Bool
forceSpecArgTy ScEnv
env Type
ty
| Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = ScEnv -> Type -> Bool
forceSpecArgTy ScEnv
env Type
ty'
forceSpecArgTy ScEnv
env Type
ty
| Just (TyCon
tycon, [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, TyCon
tycon forall a. Eq a => a -> a -> Bool
/= TyCon
funTyCon
= TyCon -> Unique
tyConUnique TyCon
tycon forall a. Eq a => a -> a -> Bool
== Unique
specTyConKey
Bool -> Bool -> Bool
|| forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (ScEnv -> NameEnv SpecConstrAnnotation
sc_annotations ScEnv
env) (TyCon -> Name
tyConName TyCon
tycon) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just SpecConstrAnnotation
ForceSpecConstr
Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ScEnv -> Type -> Bool
forceSpecArgTy ScEnv
env) [Type]
tys
forceSpecArgTy ScEnv
_ Type
_ = Bool
False
data ScUsage
= SCU {
ScUsage -> CallEnv
scu_calls :: CallEnv,
ScUsage -> IdEnv ArgOcc
scu_occs :: !(IdEnv ArgOcc)
}
type CallEnv = IdEnv [Call]
data Call = Call Id [CoreArg] ValueEnv
instance Outputable ScUsage where
ppr :: ScUsage -> SDoc
ppr (SCU { scu_calls :: ScUsage -> CallEnv
scu_calls = CallEnv
calls, scu_occs :: ScUsage -> IdEnv ArgOcc
scu_occs = IdEnv ArgOcc
occs })
= String -> SDoc
text String
"SCU" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
sep [ PtrString -> SDoc
ptext (String -> PtrString
sLit String
"calls =") SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CallEnv
calls
, String -> SDoc
text String
"occs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr IdEnv ArgOcc
occs ])
instance Outputable Call where
ppr :: Call -> SDoc
ppr (Call Id
fn [Expr Id]
args ValueEnv
_) = forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
fsep (forall a b. (a -> b) -> [a] -> [b]
map forall b. OutputableBndr b => Expr b -> SDoc
pprParendExpr [Expr Id]
args)
nullUsage :: ScUsage
nullUsage :: ScUsage
nullUsage = SCU { scu_calls :: CallEnv
scu_calls = forall a. VarEnv a
emptyVarEnv, scu_occs :: IdEnv ArgOcc
scu_occs = forall a. VarEnv a
emptyVarEnv }
combineCalls :: CallEnv -> CallEnv -> CallEnv
combineCalls :: CallEnv -> CallEnv -> CallEnv
combineCalls = forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C forall a. [a] -> [a] -> [a]
(++)
combineUsage :: ScUsage -> ScUsage -> ScUsage
combineUsage :: ScUsage -> ScUsage -> ScUsage
combineUsage ScUsage
u1 ScUsage
u2 = SCU { scu_calls :: CallEnv
scu_calls = CallEnv -> CallEnv -> CallEnv
combineCalls (ScUsage -> CallEnv
scu_calls ScUsage
u1) (ScUsage -> CallEnv
scu_calls ScUsage
u2),
scu_occs :: IdEnv ArgOcc
scu_occs = forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C ArgOcc -> ArgOcc -> ArgOcc
combineOcc (ScUsage -> IdEnv ArgOcc
scu_occs ScUsage
u1) (ScUsage -> IdEnv ArgOcc
scu_occs ScUsage
u2) }
combineUsages :: [ScUsage] -> ScUsage
combineUsages :: [ScUsage] -> ScUsage
combineUsages [] = ScUsage
nullUsage
combineUsages [ScUsage]
us = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 ScUsage -> ScUsage -> ScUsage
combineUsage [ScUsage]
us
lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
lookupOccs :: ScUsage -> [Id] -> (ScUsage, [ArgOcc])
lookupOccs (SCU { scu_calls :: ScUsage -> CallEnv
scu_calls = CallEnv
sc_calls, scu_occs :: ScUsage -> IdEnv ArgOcc
scu_occs = IdEnv ArgOcc
sc_occs }) [Id]
bndrs
= (SCU {scu_calls :: CallEnv
scu_calls = CallEnv
sc_calls, scu_occs :: IdEnv ArgOcc
scu_occs = forall a. VarEnv a -> [Id] -> VarEnv a
delVarEnvList IdEnv ArgOcc
sc_occs [Id]
bndrs},
[forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv ArgOcc
sc_occs Id
b forall a. Maybe a -> a -> a
`orElse` ArgOcc
NoOcc | Id
b <- [Id]
bndrs])
data ArgOcc = NoOcc
| UnkOcc
| ScrutOcc
(DataConEnv [ArgOcc])
type DataConEnv a = UniqFM DataCon a
instance Outputable ArgOcc where
ppr :: ArgOcc -> SDoc
ppr (ScrutOcc DataConEnv [ArgOcc]
xs) = String -> SDoc
text String
"scrut-occ" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr DataConEnv [ArgOcc]
xs
ppr ArgOcc
UnkOcc = String -> SDoc
text String
"unk-occ"
ppr ArgOcc
NoOcc = String -> SDoc
text String
"no-occ"
evalScrutOcc :: ArgOcc
evalScrutOcc :: ArgOcc
evalScrutOcc = DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc forall key elt. UniqFM key elt
emptyUFM
combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
combineOcc ArgOcc
NoOcc ArgOcc
occ = ArgOcc
occ
combineOcc ArgOcc
occ ArgOcc
NoOcc = ArgOcc
occ
combineOcc (ScrutOcc DataConEnv [ArgOcc]
xs) (ScrutOcc DataConEnv [ArgOcc]
ys) = DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc (forall elt key.
(elt -> elt -> elt)
-> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
plusUFM_C [ArgOcc] -> [ArgOcc] -> [ArgOcc]
combineOccs DataConEnv [ArgOcc]
xs DataConEnv [ArgOcc]
ys)
combineOcc ArgOcc
UnkOcc (ScrutOcc DataConEnv [ArgOcc]
ys) = DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc DataConEnv [ArgOcc]
ys
combineOcc (ScrutOcc DataConEnv [ArgOcc]
xs) ArgOcc
UnkOcc = DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc DataConEnv [ArgOcc]
xs
combineOcc ArgOcc
UnkOcc ArgOcc
UnkOcc = ArgOcc
UnkOcc
combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
combineOccs [ArgOcc]
xs [ArgOcc]
ys = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"combineOccs" ArgOcc -> ArgOcc -> ArgOcc
combineOcc [ArgOcc]
xs [ArgOcc]
ys
setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
setScrutOcc :: ScEnv -> ScUsage -> Expr Id -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
usg (Cast Expr Id
e Coercion
_) ArgOcc
occ = ScEnv -> ScUsage -> Expr Id -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
usg Expr Id
e ArgOcc
occ
setScrutOcc ScEnv
env ScUsage
usg (Tick CoreTickish
_ Expr Id
e) ArgOcc
occ = ScEnv -> ScUsage -> Expr Id -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
usg Expr Id
e ArgOcc
occ
setScrutOcc ScEnv
env ScUsage
usg (Var Id
v) ArgOcc
occ
| Just HowBound
RecArg <- ScEnv -> Id -> Maybe HowBound
lookupHowBound ScEnv
env Id
v = ScUsage
usg { scu_occs :: IdEnv ArgOcc
scu_occs = forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (ScUsage -> IdEnv ArgOcc
scu_occs ScUsage
usg) Id
v ArgOcc
occ }
| Bool
otherwise = ScUsage
usg
setScrutOcc ScEnv
_env ScUsage
usg Expr Id
_other ArgOcc
_occ
= ScUsage
usg
scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
scExpr :: ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env Expr Id
e = ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr' ScEnv
env Expr Id
e
scExpr' :: ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr' ScEnv
env (Var Id
v) = case ScEnv -> Id -> Expr Id
scSubstId ScEnv
env Id
v of
Var Id
v' -> forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv -> Id -> [Expr Id] -> ScUsage
mkVarUsage ScEnv
env Id
v' [], forall b. Id -> Expr b
Var Id
v')
Expr Id
e' -> ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr (ScEnv -> ScEnv
zapScSubst ScEnv
env) Expr Id
e'
scExpr' ScEnv
env (Type Type
t) = forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, forall b. Type -> Expr b
Type (ScEnv -> Type -> Type
scSubstTy ScEnv
env Type
t))
scExpr' ScEnv
env (Coercion Coercion
c) = forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, forall b. Coercion -> Expr b
Coercion (ScEnv -> Coercion -> Coercion
scSubstCo ScEnv
env Coercion
c))
scExpr' ScEnv
_ e :: Expr Id
e@(Lit {}) = forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, Expr Id
e)
scExpr' ScEnv
env (Tick CoreTickish
t Expr Id
e) = do (ScUsage
usg, Expr Id
e') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env Expr Id
e
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg, forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t Expr Id
e')
scExpr' ScEnv
env (Cast Expr Id
e Coercion
co) = do (ScUsage
usg, Expr Id
e') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env Expr Id
e
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg, Expr Id -> Coercion -> Expr Id
mkCast Expr Id
e' (ScEnv -> Coercion -> Coercion
scSubstCo ScEnv
env Coercion
co))
scExpr' ScEnv
env e :: Expr Id
e@(App Expr Id
_ Expr Id
_) = ScEnv -> (Expr Id, [Expr Id]) -> UniqSM (ScUsage, Expr Id)
scApp ScEnv
env (forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr Id
e)
scExpr' ScEnv
env (Lam Id
b Expr Id
e) = do let (ScEnv
env', Id
b') = ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env Id
b
(ScUsage
usg, Expr Id
e') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env' Expr Id
e
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg, forall b. b -> Expr b -> Expr b
Lam Id
b' Expr Id
e')
scExpr' ScEnv
env (Case Expr Id
scrut Id
b Type
ty [Alt Id]
alts)
= do { (ScUsage
scrut_usg, Expr Id
scrut') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env Expr Id
scrut
; case ValueEnv -> Expr Id -> Maybe Value
isValue (ScEnv -> ValueEnv
sc_vals ScEnv
env) Expr Id
scrut' of
Just (ConVal AltCon
con [Expr Id]
args) -> AltCon -> [Expr Id] -> Expr Id -> UniqSM (ScUsage, Expr Id)
sc_con_app AltCon
con [Expr Id]
args Expr Id
scrut'
Maybe Value
_other -> ScUsage -> Expr Id -> UniqSM (ScUsage, Expr Id)
sc_vanilla ScUsage
scrut_usg Expr Id
scrut'
}
where
sc_con_app :: AltCon -> [Expr Id] -> Expr Id -> UniqSM (ScUsage, Expr Id)
sc_con_app AltCon
con [Expr Id]
args Expr Id
scrut'
= do { let Alt AltCon
_ [Id]
bs Expr Id
rhs = forall b. AltCon -> [Alt b] -> Maybe (Alt b)
findAlt AltCon
con [Alt Id]
alts
forall a. Maybe a -> a -> a
`orElse` forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] (Type -> Expr Id
mkImpossibleExpr Type
ty)
alt_env' :: ScEnv
alt_env' = ScEnv -> [(Id, Expr Id)] -> ScEnv
extendScSubstList ScEnv
env ((Id
b,Expr Id
scrut') forall a. a -> [a] -> [a]
: [Id]
bs forall a b. [a] -> [b] -> [(a, b)]
`zip` AltCon -> [Expr Id] -> [Expr Id]
trimConArgs AltCon
con [Expr Id]
args)
; ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
alt_env' Expr Id
rhs }
sc_vanilla :: ScUsage -> Expr Id -> UniqSM (ScUsage, Expr Id)
sc_vanilla ScUsage
scrut_usg Expr Id
scrut'
= do { let (ScEnv
alt_env,Id
b') = HowBound -> ScEnv -> Id -> (ScEnv, Id)
extendBndrWith HowBound
RecArg ScEnv
env Id
b
; ([ScUsage]
alt_usgs, [ArgOcc]
alt_occs, [Alt Id]
alts')
<- forall (m :: * -> *) a b c d.
Monad m =>
(a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M (ScEnv
-> Expr Id -> Id -> Alt Id -> UniqSM (ScUsage, ArgOcc, Alt Id)
sc_alt ScEnv
alt_env Expr Id
scrut' Id
b') [Alt Id]
alts
; let scrut_occ :: ArgOcc
scrut_occ = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ArgOcc -> ArgOcc -> ArgOcc
combineOcc ArgOcc
NoOcc [ArgOcc]
alt_occs
scrut_usg' :: ScUsage
scrut_usg' = ScEnv -> ScUsage -> Expr Id -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
scrut_usg Expr Id
scrut' ArgOcc
scrut_occ
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ScUsage -> ScUsage -> ScUsage
combineUsage ScUsage
scrut_usg' [ScUsage]
alt_usgs,
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr Id
scrut' Id
b' (ScEnv -> Type -> Type
scSubstTy ScEnv
env Type
ty) [Alt Id]
alts') }
sc_alt :: ScEnv
-> Expr Id -> Id -> Alt Id -> UniqSM (ScUsage, ArgOcc, Alt Id)
sc_alt ScEnv
env Expr Id
scrut' Id
b' (Alt AltCon
con [Id]
bs Expr Id
rhs)
= do { let (ScEnv
env1, [Id]
bs1) = HowBound -> ScEnv -> [Id] -> (ScEnv, [Id])
extendBndrsWith HowBound
RecArg ScEnv
env [Id]
bs
(ScEnv
env2, [Id]
bs2) = ScEnv -> Expr Id -> Id -> AltCon -> [Id] -> (ScEnv, [Id])
extendCaseBndrs ScEnv
env1 Expr Id
scrut' Id
b' AltCon
con [Id]
bs1
; (ScUsage
usg, Expr Id
rhs') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env2 Expr Id
rhs
; let (ScUsage
usg', ArgOcc
b_occ:[ArgOcc]
arg_occs) = ScUsage -> [Id] -> (ScUsage, [ArgOcc])
lookupOccs ScUsage
usg (Id
b'forall a. a -> [a] -> [a]
:[Id]
bs2)
scrut_occ :: ArgOcc
scrut_occ = case AltCon
con of
DataAlt DataCon
dc -> DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc (forall key elt. Uniquable key => key -> elt -> UniqFM key elt
unitUFM DataCon
dc [ArgOcc]
arg_occs)
AltCon
_ -> DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc forall key elt. UniqFM key elt
emptyUFM
; forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg', ArgOcc
b_occ ArgOcc -> ArgOcc -> ArgOcc
`combineOcc` ArgOcc
scrut_occ, forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bs2 Expr Id
rhs') }
scExpr' ScEnv
env (Let (NonRec Id
bndr Expr Id
rhs) Expr Id
body)
| Id -> Bool
isTyVar Id
bndr
= ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr' (ScEnv -> Id -> Expr Id -> ScEnv
extendScSubst ScEnv
env Id
bndr Expr Id
rhs) Expr Id
body
| Bool
otherwise
= do { let (ScEnv
body_env, Id
bndr') = ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env Id
bndr
; RhsInfo
rhs_info <- ScEnv -> (Id, Expr Id) -> UniqSM RhsInfo
scRecRhs ScEnv
env (Id
bndr',Expr Id
rhs)
; let body_env2 :: ScEnv
body_env2 = ScEnv -> [Id] -> HowBound -> ScEnv
extendHowBound ScEnv
body_env [Id
bndr'] HowBound
RecFun
rhs' :: Expr Id
rhs' = RhsInfo -> Expr Id
ri_new_rhs RhsInfo
rhs_info
body_env3 :: ScEnv
body_env3 = ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv ScEnv
body_env2 Id
bndr' (ValueEnv -> Expr Id -> Maybe Value
isValue (ScEnv -> ValueEnv
sc_vals ScEnv
env) Expr Id
rhs')
; (ScUsage
body_usg, Expr Id
body') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
body_env3 Expr Id
body
; (ScUsage
spec_usg, SpecInfo
specs) <- ScEnv -> ScUsage -> RhsInfo -> UniqSM (ScUsage, SpecInfo)
specNonRec ScEnv
env ScUsage
body_usg RhsInfo
rhs_info
; forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
body_usg { scu_calls :: CallEnv
scu_calls = ScUsage -> CallEnv
scu_calls ScUsage
body_usg forall a. VarEnv a -> Id -> VarEnv a
`delVarEnv` Id
bndr' }
ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
spec_usg,
forall b. [Bind b] -> Expr b -> Expr b
mkLets [forall b. b -> Expr b -> Bind b
NonRec Id
b Expr Id
r | (Id
b,Expr Id
r) <- RhsInfo -> SpecInfo -> [(Id, Expr Id)]
ruleInfoBinds RhsInfo
rhs_info SpecInfo
specs] Expr Id
body')
}
scExpr' ScEnv
env (Let (Rec [(Id, Expr Id)]
prs) Expr Id
body)
= do { let ([Id]
bndrs,[Expr Id]
rhss) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, Expr Id)]
prs
(ScEnv
rhs_env1,[Id]
bndrs') = ScEnv -> [Id] -> (ScEnv, [Id])
extendRecBndrs ScEnv
env [Id]
bndrs
rhs_env2 :: ScEnv
rhs_env2 = ScEnv -> [Id] -> HowBound -> ScEnv
extendHowBound ScEnv
rhs_env1 [Id]
bndrs' HowBound
RecFun
force_spec :: Bool
force_spec = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ScEnv -> Id -> Bool
forceSpecBndr ScEnv
env) [Id]
bndrs'
; [RhsInfo]
rhs_infos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ScEnv -> (Id, Expr Id) -> UniqSM RhsInfo
scRecRhs ScEnv
rhs_env2) ([Id]
bndrs' forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr Id]
rhss)
; (ScUsage
body_usg, Expr Id
body') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
rhs_env2 Expr Id
body
; (ScUsage
spec_usg, [SpecInfo]
specs) <- TopLevelFlag
-> ScEnv -> ScUsage -> [RhsInfo] -> UniqSM (ScUsage, [SpecInfo])
specRec TopLevelFlag
NotTopLevel (ScEnv -> Bool -> ScEnv
scForce ScEnv
rhs_env2 Bool
force_spec)
ScUsage
body_usg [RhsInfo]
rhs_infos
; let all_usg :: ScUsage
all_usg = ScUsage
spec_usg ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
body_usg
bind' :: CoreBind
bind' = forall b. [(b, Expr b)] -> Bind b
Rec (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"scExpr'" RhsInfo -> SpecInfo -> [(Id, Expr Id)]
ruleInfoBinds [RhsInfo]
rhs_infos [SpecInfo]
specs))
; forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
all_usg { scu_calls :: CallEnv
scu_calls = ScUsage -> CallEnv
scu_calls ScUsage
all_usg forall a. VarEnv a -> [Id] -> VarEnv a
`delVarEnvList` [Id]
bndrs' },
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind' Expr Id
body') }
scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
scApp :: ScEnv -> (Expr Id, [Expr Id]) -> UniqSM (ScUsage, Expr Id)
scApp ScEnv
env (Var Id
fn, [Expr Id]
args)
= ASSERT( not (null args) )
do { [(ScUsage, Expr Id)]
args_w_usgs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env) [Expr Id]
args
; let ([ScUsage]
arg_usgs, [Expr Id]
args') = forall a b. [(a, b)] -> ([a], [b])
unzip [(ScUsage, Expr Id)]
args_w_usgs
arg_usg :: ScUsage
arg_usg = [ScUsage] -> ScUsage
combineUsages [ScUsage]
arg_usgs
; case ScEnv -> Id -> Expr Id
scSubstId ScEnv
env Id
fn of
fn' :: Expr Id
fn'@(Lam {}) -> ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr (ScEnv -> ScEnv
zapScSubst ScEnv
env) (Expr Id -> [Expr Id] -> Expr Id
doBeta Expr Id
fn' [Expr Id]
args')
Var Id
fn' -> forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
arg_usg ScUsage -> ScUsage -> ScUsage
`combineUsage` ScEnv -> Id -> [Expr Id] -> ScUsage
mkVarUsage ScEnv
env Id
fn' [Expr Id]
args',
forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
fn') [Expr Id]
args')
Expr Id
other_fn' -> forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
arg_usg, forall b. Expr b -> [Expr b] -> Expr b
mkApps Expr Id
other_fn' [Expr Id]
args') }
where
doBeta :: OutExpr -> [OutExpr] -> OutExpr
doBeta :: Expr Id -> [Expr Id] -> Expr Id
doBeta (Lam Id
bndr Expr Id
body) (Expr Id
arg : [Expr Id]
args) = forall b. Bind b -> Expr b -> Expr b
Let (forall b. b -> Expr b -> Bind b
NonRec Id
bndr Expr Id
arg) (Expr Id -> [Expr Id] -> Expr Id
doBeta Expr Id
body [Expr Id]
args)
doBeta Expr Id
fn [Expr Id]
args = forall b. Expr b -> [Expr b] -> Expr b
mkApps Expr Id
fn [Expr Id]
args
scApp ScEnv
env (Expr Id
other_fn, [Expr Id]
args)
= do { (ScUsage
fn_usg, Expr Id
fn') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env Expr Id
other_fn
; ([ScUsage]
arg_usgs, [Expr Id]
args') <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env) [Expr Id]
args
; forall (m :: * -> *) a. Monad m => a -> m a
return ([ScUsage] -> ScUsage
combineUsages [ScUsage]
arg_usgs ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
fn_usg, forall b. Expr b -> [Expr b] -> Expr b
mkApps Expr Id
fn' [Expr Id]
args') }
mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
mkVarUsage :: ScEnv -> Id -> [Expr Id] -> ScUsage
mkVarUsage ScEnv
env Id
fn [Expr Id]
args
= case ScEnv -> Id -> Maybe HowBound
lookupHowBound ScEnv
env Id
fn of
Just HowBound
RecFun -> SCU { scu_calls :: CallEnv
scu_calls = forall a. Id -> a -> VarEnv a
unitVarEnv Id
fn [Id -> [Expr Id] -> ValueEnv -> Call
Call Id
fn [Expr Id]
args (ScEnv -> ValueEnv
sc_vals ScEnv
env)]
, scu_occs :: IdEnv ArgOcc
scu_occs = forall a. VarEnv a
emptyVarEnv }
Just HowBound
RecArg -> SCU { scu_calls :: CallEnv
scu_calls = forall a. VarEnv a
emptyVarEnv
, scu_occs :: IdEnv ArgOcc
scu_occs = forall a. Id -> a -> VarEnv a
unitVarEnv Id
fn ArgOcc
arg_occ }
Maybe HowBound
Nothing -> ScUsage
nullUsage
where
arg_occ :: ArgOcc
arg_occ | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr Id]
args = ArgOcc
UnkOcc
| Bool
otherwise = ArgOcc
evalScrutOcc
scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
scTopBindEnv ScEnv
env (Rec [(Id, Expr Id)]
prs)
= do { let (ScEnv
rhs_env1,[Id]
bndrs') = ScEnv -> [Id] -> (ScEnv, [Id])
extendRecBndrs ScEnv
env [Id]
bndrs
rhs_env2 :: ScEnv
rhs_env2 = ScEnv -> [Id] -> HowBound -> ScEnv
extendHowBound ScEnv
rhs_env1 [Id]
bndrs HowBound
RecFun
prs' :: [(Id, Expr Id)]
prs' = forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs' [Expr Id]
rhss
; forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv
rhs_env2, forall b. [(b, Expr b)] -> Bind b
Rec [(Id, Expr Id)]
prs') }
where
([Id]
bndrs,[Expr Id]
rhss) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, Expr Id)]
prs
scTopBindEnv ScEnv
env (NonRec Id
bndr Expr Id
rhs)
= do { let (ScEnv
env1, Id
bndr') = ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env Id
bndr
env2 :: ScEnv
env2 = ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv ScEnv
env1 Id
bndr' (ValueEnv -> Expr Id -> Maybe Value
isValue (ScEnv -> ValueEnv
sc_vals ScEnv
env) Expr Id
rhs)
; forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv
env2, forall b. b -> Expr b -> Bind b
NonRec Id
bndr' Expr Id
rhs) }
scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
scTopBind ScEnv
env ScUsage
body_usage (Rec [(Id, Expr Id)]
prs)
| Just Int
threshold <- ScEnv -> Maybe Int
sc_size ScEnv
env
, Bool -> Bool
not Bool
force_spec
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (UnfoldingOpts -> Int -> Expr Id -> Bool
couldBeSmallEnoughToInline (ScEnv -> UnfoldingOpts
sc_uf_opts ScEnv
env) Int
threshold) [Expr Id]
rhss)
=
do { ([ScUsage]
rhs_usgs, [Expr Id]
rhss') <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env) [Expr Id]
rhss
; forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
body_usage ScUsage -> ScUsage -> ScUsage
`combineUsage` [ScUsage] -> ScUsage
combineUsages [ScUsage]
rhs_usgs, forall b. [(b, Expr b)] -> Bind b
Rec ([Id]
bndrs forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr Id]
rhss')) }
| Bool
otherwise
= do { [RhsInfo]
rhs_infos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ScEnv -> (Id, Expr Id) -> UniqSM RhsInfo
scRecRhs ScEnv
env) [(Id, Expr Id)]
prs
; (ScUsage
spec_usage, [SpecInfo]
specs) <- TopLevelFlag
-> ScEnv -> ScUsage -> [RhsInfo] -> UniqSM (ScUsage, [SpecInfo])
specRec TopLevelFlag
TopLevel (ScEnv -> Bool -> ScEnv
scForce ScEnv
env Bool
force_spec)
ScUsage
body_usage [RhsInfo]
rhs_infos
; forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
body_usage ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
spec_usage,
forall b. [(b, Expr b)] -> Bind b
Rec (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith RhsInfo -> SpecInfo -> [(Id, Expr Id)]
ruleInfoBinds [RhsInfo]
rhs_infos [SpecInfo]
specs))) }
where
([Id]
bndrs,[Expr Id]
rhss) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, Expr Id)]
prs
force_spec :: Bool
force_spec = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ScEnv -> Id -> Bool
forceSpecBndr ScEnv
env) [Id]
bndrs
scTopBind ScEnv
env ScUsage
usage (NonRec Id
bndr Expr Id
rhs)
= do { (ScUsage
rhs_usg', Expr Id
rhs') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env Expr Id
rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usage ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
rhs_usg', forall b. b -> Expr b -> Bind b
NonRec Id
bndr Expr Id
rhs') }
scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo
scRecRhs :: ScEnv -> (Id, Expr Id) -> UniqSM RhsInfo
scRecRhs ScEnv
env (Id
bndr,Expr Id
rhs)
= do { let ([Id]
arg_bndrs,Expr Id
body) = forall b. Expr b -> ([b], Expr b)
collectBinders Expr Id
rhs
(ScEnv
body_env, [Id]
arg_bndrs') = HowBound -> ScEnv -> [Id] -> (ScEnv, [Id])
extendBndrsWith HowBound
RecArg ScEnv
env [Id]
arg_bndrs
; (ScUsage
body_usg, Expr Id
body') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
body_env Expr Id
body
; let (ScUsage
rhs_usg, [ArgOcc]
arg_occs) = ScUsage -> [Id] -> (ScUsage, [ArgOcc])
lookupOccs ScUsage
body_usg [Id]
arg_bndrs'
; forall (m :: * -> *) a. Monad m => a -> m a
return (RI { ri_rhs_usg :: ScUsage
ri_rhs_usg = ScUsage
rhs_usg
, ri_fn :: Id
ri_fn = Id
bndr, ri_new_rhs :: Expr Id
ri_new_rhs = forall b. [b] -> Expr b -> Expr b
mkLams [Id]
arg_bndrs' Expr Id
body'
, ri_lam_bndrs :: [Id]
ri_lam_bndrs = [Id]
arg_bndrs, ri_lam_body :: Expr Id
ri_lam_body = Expr Id
body
, ri_arg_occs :: [ArgOcc]
ri_arg_occs = [ArgOcc]
arg_occs }) }
ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id, Expr Id)]
ruleInfoBinds (RI { ri_fn :: RhsInfo -> Id
ri_fn = Id
fn, ri_new_rhs :: RhsInfo -> Expr Id
ri_new_rhs = Expr Id
new_rhs })
(SI { si_specs :: SpecInfo -> [OneSpec]
si_specs = [OneSpec]
specs })
= [(Id
id,Expr Id
rhs) | OS { os_id :: OneSpec -> Id
os_id = Id
id, os_rhs :: OneSpec -> Expr Id
os_rhs = Expr Id
rhs } <- [OneSpec]
specs] forall a. [a] -> [a] -> [a]
++
[(Id
fn Id -> [CoreRule] -> Id
`addIdSpecialisations` [CoreRule]
rules, Expr Id
new_rhs)]
where
rules :: [CoreRule]
rules = [CoreRule
r | OS { os_rule :: OneSpec -> CoreRule
os_rule = CoreRule
r } <- [OneSpec]
specs]
data RhsInfo
= RI { RhsInfo -> Id
ri_fn :: OutId
, RhsInfo -> Expr Id
ri_new_rhs :: OutExpr
, RhsInfo -> ScUsage
ri_rhs_usg :: ScUsage
, RhsInfo -> [Id]
ri_lam_bndrs :: [InVar]
, RhsInfo -> Expr Id
ri_lam_body :: InExpr
, RhsInfo -> [ArgOcc]
ri_arg_occs :: [ArgOcc]
}
data SpecInfo
= SI { SpecInfo -> [OneSpec]
si_specs :: [OneSpec]
, SpecInfo -> Int
si_n_specs :: Int
, SpecInfo -> Maybe ScUsage
si_mb_unspec :: Maybe ScUsage
}
data OneSpec =
OS { OneSpec -> CallPat
os_pat :: CallPat
, OneSpec -> CoreRule
os_rule :: CoreRule
, OneSpec -> Id
os_id :: OutId
, OneSpec -> Expr Id
os_rhs :: OutExpr }
noSpecInfo :: SpecInfo
noSpecInfo :: SpecInfo
noSpecInfo = SI { si_specs :: [OneSpec]
si_specs = [], si_n_specs :: Int
si_n_specs = Int
0, si_mb_unspec :: Maybe ScUsage
si_mb_unspec = forall a. Maybe a
Nothing }
specNonRec :: ScEnv
-> ScUsage
-> RhsInfo
-> UniqSM (ScUsage, SpecInfo)
specNonRec :: ScEnv -> ScUsage -> RhsInfo -> UniqSM (ScUsage, SpecInfo)
specNonRec ScEnv
env ScUsage
body_usg RhsInfo
rhs_info
= ScEnv
-> CallEnv -> RhsInfo -> SpecInfo -> UniqSM (ScUsage, SpecInfo)
specialise ScEnv
env (ScUsage -> CallEnv
scu_calls ScUsage
body_usg) RhsInfo
rhs_info
(SpecInfo
noSpecInfo { si_mb_unspec :: Maybe ScUsage
si_mb_unspec = forall a. a -> Maybe a
Just (RhsInfo -> ScUsage
ri_rhs_usg RhsInfo
rhs_info) })
specRec :: TopLevelFlag -> ScEnv
-> ScUsage
-> [RhsInfo]
-> UniqSM (ScUsage, [SpecInfo])
specRec :: TopLevelFlag
-> ScEnv -> ScUsage -> [RhsInfo] -> UniqSM (ScUsage, [SpecInfo])
specRec TopLevelFlag
top_lvl ScEnv
env ScUsage
body_usg [RhsInfo]
rhs_infos
= Int
-> CallEnv -> ScUsage -> [SpecInfo] -> UniqSM (ScUsage, [SpecInfo])
go Int
1 CallEnv
seed_calls ScUsage
nullUsage [SpecInfo]
init_spec_infos
where
(CallEnv
seed_calls, [SpecInfo]
init_spec_infos)
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> Bool
isExportedId forall b c a. (b -> c) -> (a -> b) -> a -> c
. RhsInfo -> Id
ri_fn) [RhsInfo]
rhs_infos
= (CallEnv
all_calls, [SpecInfo
noSpecInfo | RhsInfo
_ <- [RhsInfo]
rhs_infos])
| Bool
otherwise
= (CallEnv
calls_in_body, [SpecInfo
noSpecInfo { si_mb_unspec :: Maybe ScUsage
si_mb_unspec = forall a. a -> Maybe a
Just (RhsInfo -> ScUsage
ri_rhs_usg RhsInfo
ri) }
| RhsInfo
ri <- [RhsInfo]
rhs_infos])
calls_in_body :: CallEnv
calls_in_body = ScUsage -> CallEnv
scu_calls ScUsage
body_usg
calls_in_rhss :: CallEnv
calls_in_rhss = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CallEnv -> CallEnv -> CallEnv
combineCalls forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScUsage -> CallEnv
scu_calls forall b c a. (b -> c) -> (a -> b) -> a -> c
. RhsInfo -> ScUsage
ri_rhs_usg) forall a. VarEnv a
emptyVarEnv [RhsInfo]
rhs_infos
all_calls :: CallEnv
all_calls = CallEnv
calls_in_rhss CallEnv -> CallEnv -> CallEnv
`combineCalls` CallEnv
calls_in_body
go :: Int
-> CallEnv
-> ScUsage
-> [SpecInfo]
-> UniqSM (ScUsage, [SpecInfo])
go :: Int
-> CallEnv -> ScUsage -> [SpecInfo] -> UniqSM (ScUsage, [SpecInfo])
go Int
n_iter CallEnv
seed_calls ScUsage
usg_so_far [SpecInfo]
spec_infos
| forall a. VarEnv a -> Bool
isEmptyVarEnv CallEnv
seed_calls
=
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg_so_far, [SpecInfo]
spec_infos)
| Int
n_iter forall a. Ord a => a -> a -> Bool
> ScEnv -> Int
sc_recursive ScEnv
env
, ScEnv -> Bool
sc_force ScEnv
env Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isNothing (ScEnv -> Maybe Int
sc_count ScEnv
env)
, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Ord a => a -> a -> Bool
> Int
the_limit) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecInfo -> Int
si_n_specs) [SpecInfo]
spec_infos
=
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg_so_far, [SpecInfo]
spec_infos)
| Bool
otherwise
=
do { [(ScUsage, SpecInfo)]
specs_w_usg <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (ScEnv
-> CallEnv -> RhsInfo -> SpecInfo -> UniqSM (ScUsage, SpecInfo)
specialise ScEnv
env CallEnv
seed_calls) [RhsInfo]
rhs_infos [SpecInfo]
spec_infos
; let ([ScUsage]
extra_usg_s, [SpecInfo]
new_spec_infos) = forall a b. [(a, b)] -> ([a], [b])
unzip [(ScUsage, SpecInfo)]
specs_w_usg
extra_usg :: ScUsage
extra_usg = [ScUsage] -> ScUsage
combineUsages [ScUsage]
extra_usg_s
all_usg :: ScUsage
all_usg = ScUsage
usg_so_far ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
extra_usg
; Int
-> CallEnv -> ScUsage -> [SpecInfo] -> UniqSM (ScUsage, [SpecInfo])
go (Int
n_iter forall a. Num a => a -> a -> a
+ Int
1) (ScUsage -> CallEnv
scu_calls ScUsage
extra_usg) ScUsage
all_usg [SpecInfo]
new_spec_infos }
the_limit :: Int
the_limit = case ScEnv -> Maybe Int
sc_count ScEnv
env of
Maybe Int
Nothing -> Int
10
Just Int
max -> Int
max
specialise
:: ScEnv
-> CallEnv
-> RhsInfo
-> SpecInfo
-> UniqSM (ScUsage, SpecInfo)
specialise :: ScEnv
-> CallEnv -> RhsInfo -> SpecInfo -> UniqSM (ScUsage, SpecInfo)
specialise ScEnv
env CallEnv
bind_calls (RI { ri_fn :: RhsInfo -> Id
ri_fn = Id
fn, ri_lam_bndrs :: RhsInfo -> [Id]
ri_lam_bndrs = [Id]
arg_bndrs
, ri_lam_body :: RhsInfo -> Expr Id
ri_lam_body = Expr Id
body, ri_arg_occs :: RhsInfo -> [ArgOcc]
ri_arg_occs = [ArgOcc]
arg_occs })
spec_info :: SpecInfo
spec_info@(SI { si_specs :: SpecInfo -> [OneSpec]
si_specs = [OneSpec]
specs, si_n_specs :: SpecInfo -> Int
si_n_specs = Int
spec_count
, si_mb_unspec :: SpecInfo -> Maybe ScUsage
si_mb_unspec = Maybe ScUsage
mb_unspec })
| Id -> Bool
isDeadEndId Id
fn
=
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, SpecInfo
spec_info)
| Activation -> Bool
isNeverActive (Id -> Activation
idInlineActivation Id
fn)
Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
arg_bndrs
=
case Maybe ScUsage
mb_unspec of
Just ScUsage
rhs_usg -> forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
rhs_usg, SpecInfo
spec_info { si_mb_unspec :: Maybe ScUsage
si_mb_unspec = forall a. Maybe a
Nothing })
Maybe ScUsage
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, SpecInfo
spec_info)
| Just [Call]
all_calls <- forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv CallEnv
bind_calls Id
fn
=
do { (Bool
boring_call, [CallPat]
new_pats) <- ScEnv
-> Id -> SpecInfo -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
callsToNewPats ScEnv
env Id
fn SpecInfo
spec_info [ArgOcc]
arg_occs [Call]
all_calls
; let n_pats :: Int
n_pats = forall (t :: * -> *) a. Foldable t => t a -> Int
length [CallPat]
new_pats
; let spec_env :: ScEnv
spec_env = ScEnv -> Int -> ScEnv
decreaseSpecCount ScEnv
env Int
n_pats
; ([ScUsage]
spec_usgs, [OneSpec]
new_specs) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (ScEnv
-> Id
-> [Id]
-> Expr Id
-> (CallPat, Int)
-> UniqSM (ScUsage, OneSpec)
spec_one ScEnv
spec_env Id
fn [Id]
arg_bndrs Expr Id
body)
([CallPat]
new_pats forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
spec_count..])
; let spec_usg :: ScUsage
spec_usg = [ScUsage] -> ScUsage
combineUsages [ScUsage]
spec_usgs
(ScUsage
new_usg, Maybe ScUsage
mb_unspec')
= case Maybe ScUsage
mb_unspec of
Just ScUsage
rhs_usg | Bool
boring_call -> (ScUsage
spec_usg ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
rhs_usg, forall a. Maybe a
Nothing)
Maybe ScUsage
_ -> (ScUsage
spec_usg, Maybe ScUsage
mb_unspec)
; forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
new_usg, SI { si_specs :: [OneSpec]
si_specs = [OneSpec]
new_specs forall a. [a] -> [a] -> [a]
++ [OneSpec]
specs
, si_n_specs :: Int
si_n_specs = Int
spec_count forall a. Num a => a -> a -> a
+ Int
n_pats
, si_mb_unspec :: Maybe ScUsage
si_mb_unspec = Maybe ScUsage
mb_unspec' }) }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, SpecInfo
spec_info)
spec_one :: ScEnv
-> OutId
-> [InVar]
-> InExpr
-> (CallPat, Int)
-> UniqSM (ScUsage, OneSpec)
spec_one :: ScEnv
-> Id
-> [Id]
-> Expr Id
-> (CallPat, Int)
-> UniqSM (ScUsage, OneSpec)
spec_one ScEnv
env Id
fn [Id]
arg_bndrs Expr Id
body (call_pat :: CallPat
call_pat@([Id]
qvars, [Expr Id]
pats), Int
rule_number)
= do { Unique
spec_uniq <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let spec_env :: ScEnv
spec_env = ScEnv -> [(Id, Expr Id)] -> ScEnv
extendScSubstList (ScEnv -> [Id] -> ScEnv
extendScInScope ScEnv
env [Id]
qvars)
([Id]
arg_bndrs forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr Id]
pats)
fn_name :: Name
fn_name = Id -> Name
idName Id
fn
fn_loc :: SrcSpan
fn_loc = Name -> SrcSpan
nameSrcSpan Name
fn_name
fn_occ :: OccName
fn_occ = Name -> OccName
nameOccName Name
fn_name
spec_occ :: OccName
spec_occ = OccName -> OccName
mkSpecOcc OccName
fn_occ
rule_name :: FastString
rule_name = String -> FastString
mkFastString (String
"SC:" forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString OccName
fn_occ forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
rule_number)
spec_name :: Name
spec_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
spec_uniq OccName
spec_occ SrcSpan
fn_loc
; (ScUsage
spec_usg, Expr Id
spec_body) <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
spec_env Expr Id
body
; let ([Id]
spec_lam_args, [Id]
spec_call_args) = DynFlags -> [Id] -> Type -> ([Id], [Id])
mkWorkerArgs (ScEnv -> DynFlags
sc_dflags ScEnv
env)
[Id]
qvars Type
body_ty
spec_lam_args_str :: [Id]
spec_lam_args_str = [Demand] -> [Id] -> [Id]
handOutStrictnessInformation (forall a b. (a, b) -> a
fst (StrictSig -> ([Demand], Divergence)
splitStrictSig StrictSig
spec_str)) [Id]
spec_lam_args
spec_join_arity :: Maybe Int
spec_join_arity | Id -> Bool
isJoinId Id
fn = forall a. a -> Maybe a
Just (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
spec_lam_args)
| Bool
otherwise = forall a. Maybe a
Nothing
spec_id :: Id
spec_id = HasDebugCallStack => Name -> Type -> Type -> Id
mkLocalId Name
spec_name Type
Many
([Id] -> Type -> Type
mkLamTypes [Id]
spec_lam_args Type
body_ty)
Id -> StrictSig -> Id
`setIdStrictness` StrictSig
spec_str
Id -> CprSig -> Id
`setIdCprInfo` CprSig
topCprSig
Id -> Int -> Id
`setIdArity` forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
spec_lam_args
Id -> Maybe Int -> Id
`asJoinId_maybe` Maybe Int
spec_join_arity
spec_str :: StrictSig
spec_str = Id -> [Id] -> [Expr Id] -> StrictSig
calcSpecStrictness Id
fn [Id]
spec_lam_args [Expr Id]
pats
spec_rhs :: Expr Id
spec_rhs = forall b. [b] -> Expr b -> Expr b
mkLams [Id]
spec_lam_args_str Expr Id
spec_body
body_ty :: Type
body_ty = Expr Id -> Type
exprType Expr Id
spec_body
rule_rhs :: Expr Id
rule_rhs = forall b. Expr b -> [Id] -> Expr b
mkVarApps (forall b. Id -> Expr b
Var Id
spec_id) [Id]
spec_call_args
inline_act :: Activation
inline_act = Id -> Activation
idInlineActivation Id
fn
this_mod :: Module
this_mod = ScEnv -> Module
sc_module ScEnv
spec_env
rule :: CoreRule
rule = Module
-> Bool
-> Bool
-> FastString
-> Activation
-> Name
-> [Id]
-> [Expr Id]
-> Expr Id
-> CoreRule
mkRule Module
this_mod Bool
True Bool
True
FastString
rule_name Activation
inline_act Name
fn_name [Id]
qvars [Expr Id]
pats Expr Id
rule_rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
spec_usg, OS { os_pat :: CallPat
os_pat = CallPat
call_pat, os_rule :: CoreRule
os_rule = CoreRule
rule
, os_id :: Id
os_id = Id
spec_id
, os_rhs :: Expr Id
os_rhs = Expr Id
spec_rhs }) }
handOutStrictnessInformation :: [Demand] -> [Var] -> [Var]
handOutStrictnessInformation :: [Demand] -> [Id] -> [Id]
handOutStrictnessInformation = [Demand] -> [Id] -> [Id]
go
where
go :: [Demand] -> [Id] -> [Id]
go [Demand]
_ [] = []
go [] [Id]
vs = [Id]
vs
go (Demand
d:[Demand]
dmds) (Id
v:[Id]
vs) | Id -> Bool
isId Id
v = Id -> Demand -> Id
setIdDemandInfo Id
v Demand
d forall a. a -> [a] -> [a]
: [Demand] -> [Id] -> [Id]
go [Demand]
dmds [Id]
vs
go [Demand]
dmds (Id
v:[Id]
vs) = Id
v forall a. a -> [a] -> [a]
: [Demand] -> [Id] -> [Id]
go [Demand]
dmds [Id]
vs
calcSpecStrictness :: Id
-> [Var] -> [CoreExpr]
-> StrictSig
calcSpecStrictness :: Id -> [Id] -> [Expr Id] -> StrictSig
calcSpecStrictness Id
fn [Id]
qvars [Expr Id]
pats
= [Demand] -> Divergence -> StrictSig
mkClosedStrictSig [Demand]
spec_dmds Divergence
div
where
spec_dmds :: [Demand]
spec_dmds = [ forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv DmdEnv
dmd_env Id
qv forall a. Maybe a -> a -> a
`orElse` Demand
topDmd | Id
qv <- [Id]
qvars, Id -> Bool
isId Id
qv ]
StrictSig (DmdType DmdEnv
_ [Demand]
dmds Divergence
div) = Id -> StrictSig
idStrictness Id
fn
dmd_env :: DmdEnv
dmd_env = DmdEnv -> [Demand] -> [Expr Id] -> DmdEnv
go forall a. VarEnv a
emptyVarEnv [Demand]
dmds [Expr Id]
pats
go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv
go :: DmdEnv -> [Demand] -> [Expr Id] -> DmdEnv
go DmdEnv
env [Demand]
ds (Type {} : [Expr Id]
pats) = DmdEnv -> [Demand] -> [Expr Id] -> DmdEnv
go DmdEnv
env [Demand]
ds [Expr Id]
pats
go DmdEnv
env [Demand]
ds (Coercion {} : [Expr Id]
pats) = DmdEnv -> [Demand] -> [Expr Id] -> DmdEnv
go DmdEnv
env [Demand]
ds [Expr Id]
pats
go DmdEnv
env (Demand
d:[Demand]
ds) (Expr Id
pat : [Expr Id]
pats) = DmdEnv -> [Demand] -> [Expr Id] -> DmdEnv
go (DmdEnv -> Demand -> Expr Id -> DmdEnv
go_one DmdEnv
env Demand
d Expr Id
pat) [Demand]
ds [Expr Id]
pats
go DmdEnv
env [Demand]
_ [Expr Id]
_ = DmdEnv
env
go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
go_one :: DmdEnv -> Demand -> Expr Id -> DmdEnv
go_one DmdEnv
env Demand
d (Var Id
v) = forall a. (a -> a -> a) -> VarEnv a -> Id -> a -> VarEnv a
extendVarEnv_C Demand -> Demand -> Demand
plusDmd DmdEnv
env Id
v Demand
d
go_one DmdEnv
env (Card
_n :* SubDemand
cd) Expr Id
e
| (Var Id
_, [Expr Id]
args) <- forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr Id
e
, Just [Demand]
ds <- Int -> SubDemand -> Maybe [Demand]
viewProd (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr Id]
args) SubDemand
cd
= DmdEnv -> [Demand] -> [Expr Id] -> DmdEnv
go DmdEnv
env [Demand]
ds [Expr Id]
args
go_one DmdEnv
env Demand
_ Expr Id
_ = DmdEnv
env
type CallPat = ([Var], [CoreExpr])
callsToNewPats :: ScEnv -> Id
-> SpecInfo
-> [ArgOcc] -> [Call]
-> UniqSM (Bool, [CallPat])
callsToNewPats :: ScEnv
-> Id -> SpecInfo -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
callsToNewPats ScEnv
env Id
fn spec_info :: SpecInfo
spec_info@(SI { si_specs :: SpecInfo -> [OneSpec]
si_specs = [OneSpec]
done_specs }) [ArgOcc]
bndr_occs [Call]
calls
= do { [Maybe CallPat]
mb_pats <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
callToPats ScEnv
env [ArgOcc]
bndr_occs) [Call]
calls
; let have_boring_call :: Bool
have_boring_call = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. Maybe a -> Bool
isNothing [Maybe CallPat]
mb_pats
good_pats :: [CallPat]
good_pats :: [CallPat]
good_pats = forall a. [Maybe a] -> [a]
catMaybes [Maybe CallPat]
mb_pats
new_pats :: [CallPat]
new_pats = forall a. (a -> Bool) -> [a] -> [a]
filterOut CallPat -> Bool
is_done [CallPat]
good_pats
is_done :: CallPat -> Bool
is_done CallPat
p = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CallPat -> CallPat -> Bool
samePat CallPat
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneSpec -> CallPat
os_pat) [OneSpec]
done_specs
non_dups :: [CallPat]
non_dups = forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy CallPat -> CallPat -> Bool
samePat [CallPat]
new_pats
small_pats :: [CallPat]
small_pats = forall a. (a -> Bool) -> [a] -> [a]
filterOut CallPat -> Bool
too_big [CallPat]
non_dups
too_big :: CallPat -> Bool
too_big ([Id]
vars,[Expr Id]
args) = Bool -> Bool
not (DynFlags -> Int -> [Id] -> Bool
isWorkerSmallEnough (ScEnv -> DynFlags
sc_dflags ScEnv
env) (forall b. [Arg b] -> Int
valArgCount [Expr Id]
args) [Id]
vars)
trimmed_pats :: [CallPat]
trimmed_pats = ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]
trim_pats ScEnv
env Id
fn SpecInfo
spec_info [CallPat]
small_pats
; forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
have_boring_call, [CallPat]
trimmed_pats) }
trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]
trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]
trim_pats ScEnv
env Id
fn (SI { si_n_specs :: SpecInfo -> Int
si_n_specs = Int
done_spec_count }) [CallPat]
pats
| ScEnv -> Bool
sc_force ScEnv
env
Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isNothing Maybe Int
mb_scc
Bool -> Bool -> Bool
|| Int
n_remaining forall a. Ord a => a -> a -> Bool
>= Int
n_pats
=
[CallPat]
pats
| Bool
otherwise
= [CallPat] -> [CallPat]
emit_trace forall a b. (a -> b) -> a -> b
$
forall a. Int -> [a] -> [a]
take Int
n_remaining [CallPat]
sorted_pats
where
n_pats :: Int
n_pats = forall (t :: * -> *) a. Foldable t => t a -> Int
length [CallPat]
pats
spec_count' :: Int
spec_count' = Int
n_pats forall a. Num a => a -> a -> a
+ Int
done_spec_count
n_remaining :: Int
n_remaining = Int
max_specs forall a. Num a => a -> a -> a
- Int
done_spec_count
mb_scc :: Maybe Int
mb_scc = ScEnv -> Maybe Int
sc_count ScEnv
env
Just Int
max_specs = Maybe Int
mb_scc
sorted_pats :: [CallPat]
sorted_pats = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
[(CallPat
pat, CallPat -> Int
pat_cons CallPat
pat) | CallPat
pat <- [CallPat]
pats]
pat_cons :: CallPat -> Int
pat_cons :: CallPat -> Int
pat_cons ([Id]
qs, [Expr Id]
ps) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. Num a => a -> a -> a
(+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Id -> Int
n_cons) Int
0 [Expr Id]
ps
where
q_set :: CoVarSet
q_set = [Id] -> CoVarSet
mkVarSet [Id]
qs
n_cons :: Expr Id -> Int
n_cons (Var Id
v) | Id
v Id -> CoVarSet -> Bool
`elemVarSet` CoVarSet
q_set = Int
0
| Bool
otherwise = Int
1
n_cons (Cast Expr Id
e Coercion
_) = Expr Id -> Int
n_cons Expr Id
e
n_cons (App Expr Id
e1 Expr Id
e2) = Expr Id -> Int
n_cons Expr Id
e1 forall a. Num a => a -> a -> a
+ Expr Id -> Int
n_cons Expr Id
e2
n_cons (Lit {}) = Int
1
n_cons Expr Id
_ = Int
0
emit_trace :: [CallPat] -> [CallPat]
emit_trace [CallPat]
result
| Bool
debugIsOn Bool -> Bool -> Bool
|| DynFlags -> Bool
hasPprDebug (ScEnv -> DynFlags
sc_dflags ScEnv
env)
= forall a. String -> SDoc -> a -> a
pprTrace String
"SpecConstr" SDoc
msg [CallPat]
result
| Bool
otherwise
= [CallPat]
result
msg :: SDoc
msg = [SDoc] -> SDoc
vcat [ [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
fn)
, Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"has" SDoc -> SDoc -> SDoc
<+>
Int -> SDoc -> SDoc
speakNOf Int
spec_count' (String -> SDoc
text String
"call pattern") SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"but the limit is" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
max_specs) ]
, String -> SDoc
text String
"Use -fspec-constr-count=n to set the bound"
, String -> SDoc
text String
"done_spec_count =" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
done_spec_count
, String -> SDoc
text String
"Keeping " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n_remaining SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", out of" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n_pats
, String -> SDoc
text String
"Discarding:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. Int -> [a] -> [a]
drop Int
n_remaining [CallPat]
sorted_pats) ]
callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
callToPats ScEnv
env [ArgOcc]
bndr_occs call :: Call
call@(Call Id
_ [Expr Id]
args ValueEnv
con_env)
| [Expr Id]
args forall a b. [a] -> [b] -> Bool
`ltLength` [ArgOcc]
bndr_occs
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Bool
otherwise
= do { let in_scope :: InScopeSet
in_scope = Subst -> InScopeSet
substInScope (ScEnv -> Subst
sc_subst ScEnv
env)
; (Bool
interesting, [Expr Id]
pats) <- ScEnv
-> InScopeSet
-> ValueEnv
-> [Expr Id]
-> [ArgOcc]
-> UniqSM (Bool, [Expr Id])
argsToPats ScEnv
env InScopeSet
in_scope ValueEnv
con_env [Expr Id]
args [ArgOcc]
bndr_occs
; let pat_fvs :: [Id]
pat_fvs = [Expr Id] -> [Id]
exprsFreeVarsList [Expr Id]
pats
in_scope_vars :: CoVarSet
in_scope_vars = InScopeSet -> CoVarSet
getInScopeVars InScopeSet
in_scope
is_in_scope :: Id -> Bool
is_in_scope Id
v = Id
v Id -> CoVarSet -> Bool
`elemVarSet` CoVarSet
in_scope_vars
qvars :: [Id]
qvars = forall a. (a -> Bool) -> [a] -> [a]
filterOut Id -> Bool
is_in_scope [Id]
pat_fvs
([Id]
ktvs, [Id]
ids) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Id -> Bool
isTyVar [Id]
qvars
qvars' :: [Id]
qvars' = [Id] -> [Id]
scopedSort [Id]
ktvs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
sanitise [Id]
ids
sanitise :: Id -> Id
sanitise Id
id = (Type -> Type) -> Id -> Id
updateIdTypeAndMult Type -> Type
expandTypeSynonyms Id
id
bad_covars :: CoVarSet
bad_covars :: CoVarSet
bad_covars = forall a. (a -> CoVarSet) -> [a] -> CoVarSet
mapUnionVarSet Expr Id -> CoVarSet
get_bad_covars [Expr Id]
pats
get_bad_covars :: CoreArg -> CoVarSet
get_bad_covars :: Expr Id -> CoVarSet
get_bad_covars (Type Type
ty)
= (Id -> Bool) -> CoVarSet -> CoVarSet
filterVarSet (\Id
v -> Id -> Bool
isId Id
v Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
is_in_scope Id
v)) forall a b. (a -> b) -> a -> b
$
Type -> CoVarSet
tyCoVarsOfType Type
ty
get_bad_covars Expr Id
_
= CoVarSet
emptyVarSet
;
WARN( not (isEmptyVarSet bad_covars)
, text "SpecConstr: bad covars:" <+> ppr bad_covars
$$ ppr call )
if Bool
interesting Bool -> Bool -> Bool
&& CoVarSet -> Bool
isEmptyVarSet CoVarSet
bad_covars
then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ([Id]
qvars', [Expr Id]
pats))
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }
argToPat :: ScEnv
-> InScopeSet
-> ValueEnv
-> CoreArg
-> ArgOcc
-> UniqSM (Bool, CoreArg)
argToPat :: ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> UniqSM (Bool, Expr Id)
argToPat ScEnv
_env InScopeSet
_in_scope ValueEnv
_val_env arg :: Expr Id
arg@(Type {}) ArgOcc
_arg_occ
= forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Expr Id
arg)
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Tick CoreTickish
_ Expr Id
arg) ArgOcc
arg_occ
= ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> UniqSM (Bool, Expr Id)
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Let CoreBind
_ Expr Id
arg) ArgOcc
arg_occ
= ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> UniqSM (Bool, Expr Id)
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Cast Expr Id
arg Coercion
co) ArgOcc
arg_occ
| Bool -> Bool
not (ScEnv -> Type -> Bool
ignoreType ScEnv
env Type
ty2)
= do { (Bool
interesting, Expr Id
arg') <- ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> UniqSM (Bool, Expr Id)
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ
; if Bool -> Bool
not Bool
interesting then
Type -> UniqSM (Bool, Expr Id)
wildCardPat Type
ty2
else do
{
Unique
uniq <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let co_name :: Name
co_name = Unique -> FastString -> Name
mkSysTvName Unique
uniq (String -> FastString
fsLit String
"sg")
co_var :: Id
co_var = Name -> Type -> Id
mkCoVar Name
co_name (Role -> Type -> Type -> Type
mkCoercionType Role
Representational Type
ty1 Type
ty2)
; forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
interesting, forall b. Expr b -> Coercion -> Expr b
Cast Expr Id
arg' (Id -> Coercion
mkCoVarCo Id
co_var)) } }
where
Pair Type
ty1 Type
ty2 = Coercion -> Pair Type
coercionKind Coercion
co
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ
| Just (ConVal (DataAlt DataCon
dc) [Expr Id]
args) <- ValueEnv -> Expr Id -> Maybe Value
isValue ValueEnv
val_env Expr Id
arg
, Bool -> Bool
not (ScEnv -> DataCon -> Bool
ignoreDataCon ScEnv
env DataCon
dc)
, Just [ArgOcc]
arg_occs <- DataCon -> Maybe [ArgOcc]
mb_scrut DataCon
dc
= do { let ([Expr Id]
ty_args, [Expr Id]
rest_args) = forall b a. [b] -> [a] -> ([a], [a])
splitAtList (DataCon -> [Id]
dataConUnivTyVars DataCon
dc) [Expr Id]
args
; (Bool
_, [Expr Id]
args') <- ScEnv
-> InScopeSet
-> ValueEnv
-> [Expr Id]
-> [ArgOcc]
-> UniqSM (Bool, [Expr Id])
argsToPats ScEnv
env InScopeSet
in_scope ValueEnv
val_env [Expr Id]
rest_args [ArgOcc]
arg_occs
; forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
dc ([Expr Id]
ty_args forall a. [a] -> [a] -> [a]
++ [Expr Id]
args')) }
where
mb_scrut :: DataCon -> Maybe [ArgOcc]
mb_scrut DataCon
dc = case ArgOcc
arg_occ of
ScrutOcc DataConEnv [ArgOcc]
bs | Just [ArgOcc]
occs <- forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM DataConEnv [ArgOcc]
bs DataCon
dc
-> forall a. a -> Maybe a
Just ([ArgOcc]
occs)
ArgOcc
_other | ScEnv -> Bool
sc_force ScEnv
env Bool -> Bool -> Bool
|| ScEnv -> Bool
sc_keen ScEnv
env
-> forall a. a -> Maybe a
Just (forall a. a -> [a]
repeat ArgOcc
UnkOcc)
| Bool
otherwise
-> forall a. Maybe a
Nothing
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Var Id
v) ArgOcc
arg_occ
| ScEnv -> Bool
sc_force ScEnv
env Bool -> Bool -> Bool
|| case ArgOcc
arg_occ of { ArgOcc
UnkOcc -> Bool
False; ArgOcc
_other -> Bool
True },
Bool
is_value,
Bool -> Bool
not (ScEnv -> Type -> Bool
ignoreType ScEnv
env (Id -> Type
varType Id
v))
= forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, forall b. Id -> Expr b
Var Id
v)
where
is_value :: Bool
is_value
| Id -> Bool
isLocalId Id
v = Id
v Id -> InScopeSet -> Bool
`elemInScopeSet` InScopeSet
in_scope
Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust (forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv ValueEnv
val_env Id
v)
| Bool
otherwise = Unfolding -> Bool
isValueUnfolding (Id -> Unfolding
idUnfolding Id
v)
argToPat ScEnv
_env InScopeSet
_in_scope ValueEnv
_val_env Expr Id
arg ArgOcc
_arg_occ
= Type -> UniqSM (Bool, Expr Id)
wildCardPat (Expr Id -> Type
exprType Expr Id
arg)
wildCardPat :: Type -> UniqSM (Bool, CoreArg)
wildCardPat :: Type -> UniqSM (Bool, Expr Id)
wildCardPat Type
ty
= do { Unique
uniq <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let id :: Id
id = FastString -> Unique -> Type -> Type -> Id
mkSysLocalOrCoVar (String -> FastString
fsLit String
"sc") Unique
uniq Type
Many Type
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, forall b. Id -> Expr b
varToCoreExpr Id
id) }
argsToPats :: ScEnv -> InScopeSet -> ValueEnv
-> [CoreArg] -> [ArgOcc]
-> UniqSM (Bool, [CoreArg])
argsToPats :: ScEnv
-> InScopeSet
-> ValueEnv
-> [Expr Id]
-> [ArgOcc]
-> UniqSM (Bool, [Expr Id])
argsToPats ScEnv
env InScopeSet
in_scope ValueEnv
val_env [Expr Id]
args [ArgOcc]
occs
= do { [(Bool, Expr Id)]
stuff <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> UniqSM (Bool, Expr Id)
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env) [Expr Id]
args [ArgOcc]
occs
; let ([Bool]
interesting_s, [Expr Id]
args') = forall a b. [(a, b)] -> ([a], [b])
unzip [(Bool, Expr Id)]
stuff
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
interesting_s, [Expr Id]
args') }
isValue :: ValueEnv -> CoreExpr -> Maybe Value
isValue :: ValueEnv -> Expr Id -> Maybe Value
isValue ValueEnv
_env (Lit Literal
lit)
| Literal -> Bool
litIsLifted Literal
lit = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just (AltCon -> [Expr Id] -> Value
ConVal (Literal -> AltCon
LitAlt Literal
lit) [])
isValue ValueEnv
env (Var Id
v)
| Just Value
cval <- forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv ValueEnv
env Id
v
= forall a. a -> Maybe a
Just Value
cval
| Bool -> Bool
not (Id -> Bool
isLocalId Id
v) Bool -> Bool -> Bool
&& Unfolding -> Bool
isCheapUnfolding Unfolding
unf
= ValueEnv -> Expr Id -> Maybe Value
isValue ValueEnv
env (Unfolding -> Expr Id
unfoldingTemplate Unfolding
unf)
where
unf :: Unfolding
unf = Id -> Unfolding
idUnfolding Id
v
isValue ValueEnv
env (Lam Id
b Expr Id
e)
| Id -> Bool
isTyVar Id
b = case ValueEnv -> Expr Id -> Maybe Value
isValue ValueEnv
env Expr Id
e of
Just Value
_ -> forall a. a -> Maybe a
Just Value
LambdaVal
Maybe Value
Nothing -> forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just Value
LambdaVal
isValue ValueEnv
env (Tick CoreTickish
t Expr Id
e)
| Bool -> Bool
not (forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t)
= ValueEnv -> Expr Id -> Maybe Value
isValue ValueEnv
env Expr Id
e
isValue ValueEnv
_env Expr Id
expr
| (Var Id
fun, [Expr Id]
args, [CoreTickish]
_) <- forall b.
(CoreTickish -> Bool)
-> Expr b -> (Expr b, [Expr b], [CoreTickish])
collectArgsTicks (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) Expr Id
expr
= case Id -> Maybe DataCon
isDataConWorkId_maybe Id
fun of
Just DataCon
con | [Expr Id]
args forall a. [a] -> Int -> Bool
`lengthAtLeast` DataCon -> Int
dataConRepArity DataCon
con
-> forall a. a -> Maybe a
Just (AltCon -> [Expr Id] -> Value
ConVal (DataCon -> AltCon
DataAlt DataCon
con) [Expr Id]
args)
Maybe DataCon
_other | forall b. [Arg b] -> Int
valArgCount [Expr Id]
args forall a. Ord a => a -> a -> Bool
< Id -> Int
idArity Id
fun
-> forall a. a -> Maybe a
Just Value
LambdaVal
Maybe DataCon
_other -> forall a. Maybe a
Nothing
isValue ValueEnv
_env Expr Id
_expr = forall a. Maybe a
Nothing
valueIsWorkFree :: Value -> Bool
valueIsWorkFree :: Value -> Bool
valueIsWorkFree Value
LambdaVal = Bool
True
valueIsWorkFree (ConVal AltCon
_ [Expr Id]
args) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Expr Id -> Bool
exprIsWorkFree [Expr Id]
args
samePat :: CallPat -> CallPat -> Bool
samePat :: CallPat -> CallPat -> Bool
samePat ([Id]
vs1, [Expr Id]
as1) ([Id]
vs2, [Expr Id]
as2)
= forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
all2 Expr Id -> Expr Id -> Bool
same [Expr Id]
as1 [Expr Id]
as2
where
same :: Expr Id -> Expr Id -> Bool
same (Var Id
v1) (Var Id
v2)
| Id
v1 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
vs1 = Id
v2 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
vs2
| Id
v2 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
vs2 = Bool
False
| Bool
otherwise = Id
v1 forall a. Eq a => a -> a -> Bool
== Id
v2
same (Lit Literal
l1) (Lit Literal
l2) = Literal
l1forall a. Eq a => a -> a -> Bool
==Literal
l2
same (App Expr Id
f1 Expr Id
a1) (App Expr Id
f2 Expr Id
a2) = Expr Id -> Expr Id -> Bool
same Expr Id
f1 Expr Id
f2 Bool -> Bool -> Bool
&& Expr Id -> Expr Id -> Bool
same Expr Id
a1 Expr Id
a2
same (Type {}) (Type {}) = Bool
True
same (Coercion {}) (Coercion {}) = Bool
True
same (Tick CoreTickish
_ Expr Id
e1) Expr Id
e2 = Expr Id -> Expr Id -> Bool
same Expr Id
e1 Expr Id
e2
same (Cast Expr Id
e1 Coercion
_) Expr Id
e2 = Expr Id -> Expr Id -> Bool
same Expr Id
e1 Expr Id
e2
same Expr Id
e1 (Tick CoreTickish
_ Expr Id
e2) = Expr Id -> Expr Id -> Bool
same Expr Id
e1 Expr Id
e2
same Expr Id
e1 (Cast Expr Id
e2 Coercion
_) = Expr Id -> Expr Id -> Bool
same Expr Id
e1 Expr Id
e2
same Expr Id
e1 Expr Id
e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
Bool
False
bad :: Expr b -> Bool
bad (Case {}) = Bool
True
bad (Let {}) = Bool
True
bad (Lam {}) = Bool
True
bad Expr b
_other = Bool
False