{-# LANGUAGE CPP #-}
module SpecConstr(
specConstrProgram,
SpecConstrAnnotation(..)
) where
#include "HsVersions.h"
import GhcPrelude
import CoreSyn
import CoreSubst
import CoreUtils
import CoreUnfold ( couldBeSmallEnoughToInline )
import CoreFVs ( exprsFreeVarsList )
import CoreMonad
import Literal ( litIsLifted )
import HscTypes ( ModGuts(..) )
import WwLib ( isWorkerSmallEnough, mkWorkerArgs )
import DataCon
import Coercion hiding( substCo )
import Rules
import Type hiding ( substTy )
import TyCon ( tyConName )
import Id
import PprCore ( pprParendExpr )
import MkCore ( mkImpossibleExpr )
import VarEnv
import VarSet
import Name
import BasicTypes
import DynFlags ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )
, gopt, hasPprDebug )
import Maybes ( orElse, catMaybes, isJust, isNothing )
import Demand
import GHC.Serialized ( deserializeWithData )
import Util
import Pair
import UniqSupply
import Outputable
import FastString
import UniqFM
import MonadUtils
import Control.Monad ( zipWithM )
import Data.List
import PrelNames ( specTyConName )
import Module
import TyCon ( TyCon )
import GHC.Exts( SpecConstrAnnotation(..) )
import Data.Ord( comparing )
specConstrProgram :: ModGuts -> CoreM ModGuts
specConstrProgram :: ModGuts -> CoreM ModGuts
specConstrProgram ModGuts
guts
= do
DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
UniqSupply
us <- CoreM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
UniqFM SpecConstrAnnotation
annos <- ([Word8] -> SpecConstrAnnotation)
-> ModGuts -> CoreM (UniqFM SpecConstrAnnotation)
forall a.
Typeable a =>
([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
getFirstAnnotations [Word8] -> SpecConstrAnnotation
forall a. Data a => [Word8] -> a
deserializeWithData ModGuts
guts
Module
this_mod <- CoreM Module
forall (m :: * -> *). HasModule m => m Module
getModule
let binds' :: [CoreBind]
binds' = [CoreBind] -> [CoreBind]
forall a. [a] -> [a]
reverse ([CoreBind] -> [CoreBind]) -> [CoreBind] -> [CoreBind]
forall a b. (a -> b) -> a -> b
$ ([CoreBind], UniqSupply) -> [CoreBind]
forall a b. (a, b) -> a
fst (([CoreBind], UniqSupply) -> [CoreBind])
-> ([CoreBind], UniqSupply) -> [CoreBind]
forall a b. (a -> b) -> a -> b
$ UniqSupply -> UniqSM [CoreBind] -> ([CoreBind], UniqSupply)
forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
us (UniqSM [CoreBind] -> ([CoreBind], UniqSupply))
-> UniqSM [CoreBind] -> ([CoreBind], UniqSupply)
forall a b. (a -> b) -> a -> b
$ do
(ScEnv
env, [CoreBind]
binds) <- ScEnv -> [CoreBind] -> UniqSM (ScEnv, [CoreBind])
goEnv (DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv
initScEnv DynFlags
dflags Module
this_mod UniqFM SpecConstrAnnotation
annos)
(ModGuts -> [CoreBind]
mg_binds ModGuts
guts)
ScEnv -> ScUsage -> [CoreBind] -> UniqSM [CoreBind]
go ScEnv
env ScUsage
nullUsage ([CoreBind] -> [CoreBind]
forall a. [a] -> [a]
reverse [CoreBind]
binds)
ModGuts -> CoreM ModGuts
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 [] = (ScEnv, [CoreBind]) -> UniqSM (ScEnv, [CoreBind])
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
(ScEnv, [CoreBind]) -> UniqSM (ScEnv, [CoreBind])
forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv
env'', CoreBind
bind' CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
binds')
go :: ScEnv -> ScUsage -> [CoreBind] -> UniqSM [CoreBind]
go ScEnv
_ ScUsage
_ [] = [CoreBind] -> UniqSM [CoreBind]
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
[CoreBind] -> UniqSM [CoreBind]
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind
bind' CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
binds')
data ScEnv = SCE { ScEnv -> DynFlags
sc_dflags :: DynFlags,
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 -> UniqFM SpecConstrAnnotation
sc_annotations :: UniqFM 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 [CoreArg]
args) = AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
con SDoc -> SDoc -> SDoc
<+> [CoreArg] -> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [CoreArg]
args
ppr Value
LambdaVal = String -> SDoc
text String
"<Lambda>"
initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv
initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv
initScEnv DynFlags
dflags Module
this_mod UniqFM SpecConstrAnnotation
anns
= SCE :: DynFlags
-> Module
-> Maybe Int
-> Maybe Int
-> Int
-> Bool
-> Bool
-> Subst
-> HowBoundEnv
-> ValueEnv
-> UniqFM SpecConstrAnnotation
-> ScEnv
SCE { sc_dflags :: DynFlags
sc_dflags = 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 = HowBoundEnv
forall a. VarEnv a
emptyVarEnv,
sc_vals :: ValueEnv
sc_vals = ValueEnv
forall a. VarEnv a
emptyVarEnv,
sc_annotations :: UniqFM SpecConstrAnnotation
sc_annotations = UniqFM 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 = HowBoundEnv -> Id -> Maybe HowBound
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (ScEnv -> HowBoundEnv
sc_how_bound ScEnv
env) Id
id
scSubstId :: ScEnv -> Id -> CoreExpr
scSubstId :: ScEnv -> Id -> CoreArg
scSubstId ScEnv
env Id
v = SDoc -> Subst -> Id -> CoreArg
lookupIdSubst (String -> SDoc
text String
"scSubstId") (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
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 -> CoreArg -> ScEnv
extendScSubst ScEnv
env Id
var CoreArg
expr = ScEnv
env { sc_subst :: Subst
sc_subst = Subst -> Id -> CoreArg -> Subst
extendSubst (ScEnv -> Subst
sc_subst ScEnv
env) Id
var CoreArg
expr }
extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
extendScSubstList :: ScEnv -> [(Id, CoreArg)] -> ScEnv
extendScSubstList ScEnv
env [(Id, CoreArg)]
prs = ScEnv
env { sc_subst :: Subst
sc_subst = Subst -> [(Id, CoreArg)] -> Subst
extendSubstList (ScEnv -> Subst
sc_subst ScEnv
env) [(Id, CoreArg)]
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 = HowBoundEnv -> [(Id, HowBound)] -> HowBoundEnv
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 HowBoundEnv -> [(Id, HowBound)] -> HowBoundEnv
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' = HowBoundEnv -> Id -> HowBound -> HowBoundEnv
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 = ValueEnv -> Id -> Value -> ValueEnv
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 -> CoreArg -> Id -> AltCon -> [Id] -> (ScEnv, [Id])
extendCaseBndrs ScEnv
env CoreArg
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 <- (Tickish Id -> Bool) -> CoreArg -> CoreArg
forall b. (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksTopE (Bool -> Tickish Id -> Bool
forall a b. a -> b -> a
const Bool
True) CoreArg
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 CoreArg
scrut of { Var {} -> Bool
True; CoreArg
_ -> Bool
live_case_bndr }
= (Id -> Id) -> [Id] -> [Id]
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 -> Maybe Value
forall a. Maybe a
Nothing
LitAlt {} -> Value -> Maybe Value
forall a. a -> Maybe a
Just (AltCon -> [CoreArg] -> Value
ConVal AltCon
con [])
DataAlt {} -> Value -> Maybe Value
forall a. a -> Maybe a
Just (AltCon -> [CoreArg] -> Value
ConVal AltCon
con [CoreArg]
forall b. [Expr b]
vanilla_args)
where
vanilla_args :: [Expr b]
vanilla_args = (Type -> Expr b) -> [Type] -> [Expr b]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Expr b
forall b. Type -> Expr b
Type (Type -> [Type]
tyConAppArgs (Id -> Type
idType Id
case_bndr)) [Expr b] -> [Expr b] -> [Expr b]
forall a. [a] -> [a] -> [a]
++
[Id] -> [Expr b]
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 -> Maybe Int
forall a. Maybe a
Nothing
Just Int
n -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (Int
n_specs Int -> Int -> Int
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
= UniqFM SpecConstrAnnotation -> TyCon -> Maybe SpecConstrAnnotation
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM (ScEnv -> UniqFM SpecConstrAnnotation
sc_annotations ScEnv
env) TyCon
tycon Maybe SpecConstrAnnotation -> Maybe SpecConstrAnnotation -> Bool
forall a. Eq a => a -> a -> Bool
== SpecConstrAnnotation -> Maybe SpecConstrAnnotation
forall a. a -> Maybe a
Just SpecConstrAnnotation
NoSpecConstr
forceSpecBndr :: ScEnv -> Id -> Bool
forceSpecBndr ScEnv
env Id
var = ScEnv -> Type -> Bool
forceSpecFunTy ScEnv
env (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Id], Type) -> Type
forall a b. (a, b) -> b
snd (([Id], Type) -> Type) -> (Id -> ([Id], Type)) -> Id -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Id], Type)
splitForAllTys (Type -> ([Id], Type)) -> (Id -> Type) -> Id -> ([Id], Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
varType (Id -> Bool) -> Id -> Bool
forall a b. (a -> b) -> a -> b
$ Id
var
forceSpecFunTy :: ScEnv -> Type -> Bool
forceSpecFunTy :: ScEnv -> Type -> Bool
forceSpecFunTy ScEnv
env = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ScEnv -> Type -> Bool
forceSpecArgTy ScEnv
env) ([Type] -> Bool) -> (Type -> [Type]) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Type], Type) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Type) -> [Type])
-> (Type -> ([Type], Type)) -> Type -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([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])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
/= TyCon
funTyCon
= TyCon -> Name
tyConName TyCon
tycon Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
specTyConName
Bool -> Bool -> Bool
|| UniqFM SpecConstrAnnotation -> TyCon -> Maybe SpecConstrAnnotation
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM (ScEnv -> UniqFM SpecConstrAnnotation
sc_annotations ScEnv
env) TyCon
tycon Maybe SpecConstrAnnotation -> Maybe SpecConstrAnnotation -> Bool
forall a. Eq a => a -> a -> Bool
== SpecConstrAnnotation -> Maybe SpecConstrAnnotation
forall a. a -> Maybe a
Just SpecConstrAnnotation
ForceSpecConstr
Bool -> Bool -> Bool
|| (Type -> Bool) -> [Type] -> 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
<+> CallEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr CallEnv
calls
, String -> SDoc
text String
"occs =" SDoc -> SDoc -> SDoc
<+> IdEnv ArgOcc -> SDoc
forall a. Outputable a => a -> SDoc
ppr IdEnv ArgOcc
occs ])
instance Outputable Call where
ppr :: Call -> SDoc
ppr (Call Id
fn [CoreArg]
args ValueEnv
_) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
fsep ((CoreArg -> SDoc) -> [CoreArg] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CoreArg -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprParendExpr [CoreArg]
args)
nullUsage :: ScUsage
nullUsage :: ScUsage
nullUsage = SCU :: CallEnv -> IdEnv ArgOcc -> ScUsage
SCU { scu_calls :: CallEnv
scu_calls = CallEnv
forall a. VarEnv a
emptyVarEnv, scu_occs :: IdEnv ArgOcc
scu_occs = IdEnv ArgOcc
forall a. VarEnv a
emptyVarEnv }
combineCalls :: CallEnv -> CallEnv -> CallEnv
combineCalls :: CallEnv -> CallEnv -> CallEnv
combineCalls = ([Call] -> [Call] -> [Call]) -> CallEnv -> CallEnv -> CallEnv
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C [Call] -> [Call] -> [Call]
forall a. [a] -> [a] -> [a]
(++)
where
combineUsage :: ScUsage -> ScUsage -> ScUsage
combineUsage :: ScUsage -> ScUsage -> ScUsage
combineUsage ScUsage
u1 ScUsage
u2 = SCU :: CallEnv -> IdEnv ArgOcc -> ScUsage
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 = (ArgOcc -> ArgOcc -> ArgOcc)
-> IdEnv ArgOcc -> IdEnv ArgOcc -> IdEnv ArgOcc
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 = (ScUsage -> ScUsage -> ScUsage) -> [ScUsage] -> ScUsage
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 :: CallEnv -> IdEnv ArgOcc -> ScUsage
SCU {scu_calls :: CallEnv
scu_calls = CallEnv
sc_calls, scu_occs :: IdEnv ArgOcc
scu_occs = IdEnv ArgOcc -> [Id] -> IdEnv ArgOcc
forall a. VarEnv a -> [Id] -> VarEnv a
delVarEnvList IdEnv ArgOcc
sc_occs [Id]
bndrs},
[IdEnv ArgOcc -> Id -> Maybe ArgOcc
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv ArgOcc
sc_occs Id
b Maybe ArgOcc -> ArgOcc -> ArgOcc
forall a. Maybe a -> a -> a
`orElse` ArgOcc
NoOcc | Id
b <- [Id]
bndrs])
data ArgOcc = NoOcc
| UnkOcc
| ScrutOcc
(DataConEnv [ArgOcc])
type DataConEnv a = UniqFM a
instance Outputable ArgOcc where
ppr :: ArgOcc -> SDoc
ppr (ScrutOcc DataConEnv [ArgOcc]
xs) = String -> SDoc
text String
"scrut-occ" SDoc -> SDoc -> SDoc
<> DataConEnv [ArgOcc] -> 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 DataConEnv [ArgOcc]
forall a. VarEnv a
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 (([ArgOcc] -> [ArgOcc] -> [ArgOcc])
-> DataConEnv [ArgOcc]
-> DataConEnv [ArgOcc]
-> DataConEnv [ArgOcc]
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
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 = String
-> (ArgOcc -> ArgOcc -> ArgOcc) -> [ArgOcc] -> [ArgOcc] -> [ArgOcc]
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 -> CoreArg -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
usg (Cast CoreArg
e Coercion
_) ArgOcc
occ = ScEnv -> ScUsage -> CoreArg -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
usg CoreArg
e ArgOcc
occ
setScrutOcc ScEnv
env ScUsage
usg (Tick Tickish Id
_ CoreArg
e) ArgOcc
occ = ScEnv -> ScUsage -> CoreArg -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
usg CoreArg
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 = IdEnv ArgOcc -> Id -> ArgOcc -> IdEnv ArgOcc
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 CoreArg
_other ArgOcc
_occ
= ScUsage
usg
scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
scExpr :: ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
env CoreArg
e = ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr' ScEnv
env CoreArg
e
scExpr' :: ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr' ScEnv
env (Var Id
v) = case ScEnv -> Id -> CoreArg
scSubstId ScEnv
env Id
v of
Var Id
v' -> (ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv -> Id -> [CoreArg] -> ScUsage
mkVarUsage ScEnv
env Id
v' [], Id -> CoreArg
forall b. Id -> Expr b
Var Id
v')
CoreArg
e' -> ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr (ScEnv -> ScEnv
zapScSubst ScEnv
env) CoreArg
e'
scExpr' ScEnv
env (Type Type
t) = (ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, Type -> CoreArg
forall b. Type -> Expr b
Type (ScEnv -> Type -> Type
scSubstTy ScEnv
env Type
t))
scExpr' ScEnv
env (Coercion Coercion
c) = (ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, Coercion -> CoreArg
forall b. Coercion -> Expr b
Coercion (ScEnv -> Coercion -> Coercion
scSubstCo ScEnv
env Coercion
c))
scExpr' ScEnv
_ e :: CoreArg
e@(Lit {}) = (ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, CoreArg
e)
scExpr' ScEnv
env (Tick Tickish Id
t CoreArg
e) = do (ScUsage
usg, CoreArg
e') <- ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
env CoreArg
e
(ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg, Tickish Id -> CoreArg -> CoreArg
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t CoreArg
e')
scExpr' ScEnv
env (Cast CoreArg
e Coercion
co) = do (ScUsage
usg, CoreArg
e') <- ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
env CoreArg
e
(ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg, CoreArg -> Coercion -> CoreArg
mkCast CoreArg
e' (ScEnv -> Coercion -> Coercion
scSubstCo ScEnv
env Coercion
co))
scExpr' ScEnv
env e :: CoreArg
e@(App CoreArg
_ CoreArg
_) = ScEnv -> (CoreArg, [CoreArg]) -> UniqSM (ScUsage, CoreArg)
scApp ScEnv
env (CoreArg -> (CoreArg, [CoreArg])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreArg
e)
scExpr' ScEnv
env (Lam Id
b CoreArg
e) = do let (ScEnv
env', Id
b') = ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env Id
b
(ScUsage
usg, CoreArg
e') <- ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
env' CoreArg
e
(ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg, Id -> CoreArg -> CoreArg
forall b. b -> Expr b -> Expr b
Lam Id
b' CoreArg
e')
scExpr' ScEnv
env (Case CoreArg
scrut Id
b Type
ty [Alt Id]
alts)
= do { (ScUsage
scrut_usg, CoreArg
scrut') <- ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
env CoreArg
scrut
; case ValueEnv -> CoreArg -> Maybe Value
isValue (ScEnv -> ValueEnv
sc_vals ScEnv
env) CoreArg
scrut' of
Just (ConVal AltCon
con [CoreArg]
args) -> AltCon -> [CoreArg] -> CoreArg -> UniqSM (ScUsage, CoreArg)
sc_con_app AltCon
con [CoreArg]
args CoreArg
scrut'
Maybe Value
_other -> ScUsage -> CoreArg -> UniqSM (ScUsage, CoreArg)
sc_vanilla ScUsage
scrut_usg CoreArg
scrut'
}
where
sc_con_app :: AltCon -> [CoreArg] -> CoreArg -> UniqSM (ScUsage, CoreArg)
sc_con_app AltCon
con [CoreArg]
args CoreArg
scrut'
= do { let (AltCon
_, [Id]
bs, CoreArg
rhs) = AltCon -> [Alt Id] -> Maybe (Alt Id)
forall a b. AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
findAlt AltCon
con [Alt Id]
alts
Maybe (Alt Id) -> Alt Id -> Alt Id
forall a. Maybe a -> a -> a
`orElse` (AltCon
DEFAULT, [], Type -> CoreArg
mkImpossibleExpr Type
ty)
alt_env' :: ScEnv
alt_env' = ScEnv -> [(Id, CoreArg)] -> ScEnv
extendScSubstList ScEnv
env ((Id
b,CoreArg
scrut') (Id, CoreArg) -> [(Id, CoreArg)] -> [(Id, CoreArg)]
forall a. a -> [a] -> [a]
: [Id]
bs [Id] -> [CoreArg] -> [(Id, CoreArg)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` AltCon -> [CoreArg] -> [CoreArg]
trimConArgs AltCon
con [CoreArg]
args)
; ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
alt_env' CoreArg
rhs }
sc_vanilla :: ScUsage -> CoreArg -> UniqSM (ScUsage, CoreArg)
sc_vanilla ScUsage
scrut_usg CoreArg
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')
<- (Alt Id -> UniqSM (ScUsage, ArgOcc, Alt Id))
-> [Alt Id] -> UniqSM ([ScUsage], [ArgOcc], [Alt Id])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M (ScEnv
-> CoreArg -> Id -> Alt Id -> UniqSM (ScUsage, ArgOcc, Alt Id)
sc_alt ScEnv
alt_env CoreArg
scrut' Id
b') [Alt Id]
alts
; let scrut_occ :: ArgOcc
scrut_occ = (ArgOcc -> ArgOcc -> ArgOcc) -> ArgOcc -> [ArgOcc] -> ArgOcc
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 -> CoreArg -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
scrut_usg CoreArg
scrut' ArgOcc
scrut_occ
; (ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ScUsage -> ScUsage -> ScUsage) -> ScUsage -> [ScUsage] -> ScUsage
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ScUsage -> ScUsage -> ScUsage
combineUsage ScUsage
scrut_usg' [ScUsage]
alt_usgs,
CoreArg -> Id -> Type -> [Alt Id] -> CoreArg
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreArg
scrut' Id
b' (ScEnv -> Type -> Type
scSubstTy ScEnv
env Type
ty) [Alt Id]
alts') }
sc_alt :: ScEnv
-> CoreArg -> Id -> Alt Id -> UniqSM (ScUsage, ArgOcc, Alt Id)
sc_alt ScEnv
env CoreArg
scrut' Id
b' (AltCon
con,[Id]
bs,CoreArg
rhs)
= do { let (ScEnv
env1, [Id]
bs1) = HowBound -> ScEnv -> [Id] -> (ScEnv, [Id])
extendBndrsWith HowBound
RecArg ScEnv
env [Id]
bs
(ScEnv
env2, [Id]
bs2) = ScEnv -> CoreArg -> Id -> AltCon -> [Id] -> (ScEnv, [Id])
extendCaseBndrs ScEnv
env1 CoreArg
scrut' Id
b' AltCon
con [Id]
bs1
; (ScUsage
usg, CoreArg
rhs') <- ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
env2 CoreArg
rhs
; let (ScUsage
usg', ArgOcc
b_occ:[ArgOcc]
arg_occs) = ScUsage -> [Id] -> (ScUsage, [ArgOcc])
lookupOccs ScUsage
usg (Id
b'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bs2)
scrut_occ :: ArgOcc
scrut_occ = case AltCon
con of
DataAlt dc -> DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc (DataCon -> [ArgOcc] -> DataConEnv [ArgOcc]
forall key elt. Uniquable key => key -> elt -> UniqFM elt
unitUFM DataCon
dc [ArgOcc]
arg_occs)
AltCon
_ -> DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc DataConEnv [ArgOcc]
forall a. VarEnv a
emptyUFM
; (ScUsage, ArgOcc, Alt Id) -> UniqSM (ScUsage, ArgOcc, Alt Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg', ArgOcc
b_occ ArgOcc -> ArgOcc -> ArgOcc
`combineOcc` ArgOcc
scrut_occ, (AltCon
con, [Id]
bs2, CoreArg
rhs')) }
scExpr' ScEnv
env (Let (NonRec Id
bndr CoreArg
rhs) CoreArg
body)
| Id -> Bool
isTyVar Id
bndr
= ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr' (ScEnv -> Id -> CoreArg -> ScEnv
extendScSubst ScEnv
env Id
bndr CoreArg
rhs) CoreArg
body
| Bool
otherwise
= do { let (ScEnv
body_env, Id
bndr') = ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env Id
bndr
; RhsInfo
rhs_info <- ScEnv -> (Id, CoreArg) -> UniqSM RhsInfo
scRecRhs ScEnv
env (Id
bndr',CoreArg
rhs)
; let body_env2 :: ScEnv
body_env2 = ScEnv -> [Id] -> HowBound -> ScEnv
extendHowBound ScEnv
body_env [Id
bndr'] HowBound
RecFun
rhs' :: CoreArg
rhs' = RhsInfo -> CoreArg
ri_new_rhs RhsInfo
rhs_info
body_env3 :: ScEnv
body_env3 = ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv ScEnv
body_env2 Id
bndr' (ValueEnv -> CoreArg -> Maybe Value
isValue (ScEnv -> ValueEnv
sc_vals ScEnv
env) CoreArg
rhs')
; (ScUsage
body_usg, CoreArg
body') <- ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
body_env3 CoreArg
body
; (ScUsage
spec_usg, SpecInfo
specs) <- ScEnv -> ScUsage -> RhsInfo -> UniqSM (ScUsage, SpecInfo)
specNonRec ScEnv
env ScUsage
body_usg RhsInfo
rhs_info
; (ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
body_usg { scu_calls :: CallEnv
scu_calls = ScUsage -> CallEnv
scu_calls ScUsage
body_usg CallEnv -> Id -> CallEnv
forall a. VarEnv a -> Id -> VarEnv a
`delVarEnv` Id
bndr' }
ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
spec_usg,
[CoreBind] -> CoreArg -> CoreArg
forall b. [Bind b] -> Expr b -> Expr b
mkLets [Id -> CoreArg -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
b CoreArg
r | (Id
b,CoreArg
r) <- RhsInfo -> SpecInfo -> [(Id, CoreArg)]
ruleInfoBinds RhsInfo
rhs_info SpecInfo
specs] CoreArg
body')
}
scExpr' ScEnv
env (Let (Rec [(Id, CoreArg)]
prs) CoreArg
body)
= do { let ([Id]
bndrs,[CoreArg]
rhss) = [(Id, CoreArg)] -> ([Id], [CoreArg])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CoreArg)]
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 = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ScEnv -> Id -> Bool
forceSpecBndr ScEnv
env) [Id]
bndrs'
; [RhsInfo]
rhs_infos <- ((Id, CoreArg) -> UniqSM RhsInfo)
-> [(Id, CoreArg)] -> UniqSM [RhsInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ScEnv -> (Id, CoreArg) -> UniqSM RhsInfo
scRecRhs ScEnv
rhs_env2) ([Id]
bndrs' [Id] -> [CoreArg] -> [(Id, CoreArg)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreArg]
rhss)
; (ScUsage
body_usg, CoreArg
body') <- ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
rhs_env2 CoreArg
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' = [(Id, CoreArg)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([[(Id, CoreArg)]] -> [(Id, CoreArg)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((RhsInfo -> SpecInfo -> [(Id, CoreArg)])
-> [RhsInfo] -> [SpecInfo] -> [[(Id, CoreArg)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith RhsInfo -> SpecInfo -> [(Id, CoreArg)]
ruleInfoBinds [RhsInfo]
rhs_infos [SpecInfo]
specs))
; (ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
all_usg { scu_calls :: CallEnv
scu_calls = ScUsage -> CallEnv
scu_calls ScUsage
all_usg CallEnv -> [Id] -> CallEnv
forall a. VarEnv a -> [Id] -> VarEnv a
`delVarEnvList` [Id]
bndrs' },
CoreBind -> CoreArg -> CoreArg
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind' CoreArg
body') }
scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
scApp :: ScEnv -> (CoreArg, [CoreArg]) -> UniqSM (ScUsage, CoreArg)
scApp ScEnv
env (Var Id
fn, [CoreArg]
args)
= ASSERT( not (null args) )
do { [(ScUsage, CoreArg)]
args_w_usgs <- (CoreArg -> UniqSM (ScUsage, CoreArg))
-> [CoreArg] -> UniqSM [(ScUsage, CoreArg)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
env) [CoreArg]
args
; let ([ScUsage]
arg_usgs, [CoreArg]
args') = [(ScUsage, CoreArg)] -> ([ScUsage], [CoreArg])
forall a b. [(a, b)] -> ([a], [b])
unzip [(ScUsage, CoreArg)]
args_w_usgs
arg_usg :: ScUsage
arg_usg = [ScUsage] -> ScUsage
combineUsages [ScUsage]
arg_usgs
; case ScEnv -> Id -> CoreArg
scSubstId ScEnv
env Id
fn of
fn' :: CoreArg
fn'@(Lam {}) -> ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr (ScEnv -> ScEnv
zapScSubst ScEnv
env) (CoreArg -> [CoreArg] -> CoreArg
doBeta CoreArg
fn' [CoreArg]
args')
Var Id
fn' -> (ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
arg_usg ScUsage -> ScUsage -> ScUsage
`combineUsage` ScEnv -> Id -> [CoreArg] -> ScUsage
mkVarUsage ScEnv
env Id
fn' [CoreArg]
args',
CoreArg -> [CoreArg] -> CoreArg
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreArg
forall b. Id -> Expr b
Var Id
fn') [CoreArg]
args')
CoreArg
other_fn' -> (ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
arg_usg, CoreArg -> [CoreArg] -> CoreArg
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreArg
other_fn' [CoreArg]
args') }
where
doBeta :: OutExpr -> [OutExpr] -> OutExpr
doBeta :: CoreArg -> [CoreArg] -> CoreArg
doBeta (Lam Id
bndr CoreArg
body) (CoreArg
arg : [CoreArg]
args) = CoreBind -> CoreArg -> CoreArg
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreArg -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr CoreArg
arg) (CoreArg -> [CoreArg] -> CoreArg
doBeta CoreArg
body [CoreArg]
args)
doBeta CoreArg
fn [CoreArg]
args = CoreArg -> [CoreArg] -> CoreArg
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreArg
fn [CoreArg]
args
scApp ScEnv
env (CoreArg
other_fn, [CoreArg]
args)
= do { (ScUsage
fn_usg, CoreArg
fn') <- ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
env CoreArg
other_fn
; ([ScUsage]
arg_usgs, [CoreArg]
args') <- (CoreArg -> UniqSM (ScUsage, CoreArg))
-> [CoreArg] -> UniqSM ([ScUsage], [CoreArg])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
env) [CoreArg]
args
; (ScUsage, CoreArg) -> UniqSM (ScUsage, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScUsage] -> ScUsage
combineUsages [ScUsage]
arg_usgs ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
fn_usg, CoreArg -> [CoreArg] -> CoreArg
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreArg
fn' [CoreArg]
args') }
mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
mkVarUsage :: ScEnv -> Id -> [CoreArg] -> ScUsage
mkVarUsage ScEnv
env Id
fn [CoreArg]
args
= case ScEnv -> Id -> Maybe HowBound
lookupHowBound ScEnv
env Id
fn of
Just HowBound
RecFun -> SCU :: CallEnv -> IdEnv ArgOcc -> ScUsage
SCU { scu_calls :: CallEnv
scu_calls = Id -> [Call] -> CallEnv
forall a. Id -> a -> VarEnv a
unitVarEnv Id
fn [Id -> [CoreArg] -> ValueEnv -> Call
Call Id
fn [CoreArg]
args (ScEnv -> ValueEnv
sc_vals ScEnv
env)]
, scu_occs :: IdEnv ArgOcc
scu_occs = IdEnv ArgOcc
forall a. VarEnv a
emptyVarEnv }
Just HowBound
RecArg -> SCU :: CallEnv -> IdEnv ArgOcc -> ScUsage
SCU { scu_calls :: CallEnv
scu_calls = CallEnv
forall a. VarEnv a
emptyVarEnv
, scu_occs :: IdEnv ArgOcc
scu_occs = Id -> ArgOcc -> IdEnv ArgOcc
forall a. Id -> a -> VarEnv a
unitVarEnv Id
fn ArgOcc
arg_occ }
Maybe HowBound
Nothing -> ScUsage
nullUsage
where
arg_occ :: ArgOcc
arg_occ | [CoreArg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreArg]
args = ArgOcc
UnkOcc
| Bool
otherwise = ArgOcc
evalScrutOcc
scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
scTopBindEnv ScEnv
env (Rec [(Id, CoreArg)]
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, CoreArg)]
prs' = [Id] -> [CoreArg] -> [(Id, CoreArg)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs' [CoreArg]
rhss
; (ScEnv, CoreBind) -> UniqSM (ScEnv, CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv
rhs_env2, [(Id, CoreArg)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CoreArg)]
prs') }
where
([Id]
bndrs,[CoreArg]
rhss) = [(Id, CoreArg)] -> ([Id], [CoreArg])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CoreArg)]
prs
scTopBindEnv ScEnv
env (NonRec Id
bndr CoreArg
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 -> CoreArg -> Maybe Value
isValue (ScEnv -> ValueEnv
sc_vals ScEnv
env) CoreArg
rhs)
; (ScEnv, CoreBind) -> UniqSM (ScEnv, CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv
env2, Id -> CoreArg -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' CoreArg
rhs) }
scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
scTopBind ScEnv
env ScUsage
body_usage (Rec [(Id, CoreArg)]
prs)
| Just Int
threshold <- ScEnv -> Maybe Int
sc_size ScEnv
env
, Bool -> Bool
not Bool
force_spec
, Bool -> Bool
not ((CoreArg -> Bool) -> [CoreArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (DynFlags -> Int -> CoreArg -> Bool
couldBeSmallEnoughToInline (ScEnv -> DynFlags
sc_dflags ScEnv
env) Int
threshold) [CoreArg]
rhss)
=
do { ([ScUsage]
rhs_usgs, [CoreArg]
rhss') <- (CoreArg -> UniqSM (ScUsage, CoreArg))
-> [CoreArg] -> UniqSM ([ScUsage], [CoreArg])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
env) [CoreArg]
rhss
; (ScUsage, CoreBind) -> UniqSM (ScUsage, CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
body_usage ScUsage -> ScUsage -> ScUsage
`combineUsage` [ScUsage] -> ScUsage
combineUsages [ScUsage]
rhs_usgs, [(Id, CoreArg)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Id]
bndrs [Id] -> [CoreArg] -> [(Id, CoreArg)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreArg]
rhss')) }
| Bool
otherwise
= do { [RhsInfo]
rhs_infos <- ((Id, CoreArg) -> UniqSM RhsInfo)
-> [(Id, CoreArg)] -> UniqSM [RhsInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ScEnv -> (Id, CoreArg) -> UniqSM RhsInfo
scRecRhs ScEnv
env) [(Id, CoreArg)]
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
; (ScUsage, CoreBind) -> UniqSM (ScUsage, CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
body_usage ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
spec_usage,
[(Id, CoreArg)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([[(Id, CoreArg)]] -> [(Id, CoreArg)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((RhsInfo -> SpecInfo -> [(Id, CoreArg)])
-> [RhsInfo] -> [SpecInfo] -> [[(Id, CoreArg)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith RhsInfo -> SpecInfo -> [(Id, CoreArg)]
ruleInfoBinds [RhsInfo]
rhs_infos [SpecInfo]
specs))) }
where
([Id]
bndrs,[CoreArg]
rhss) = [(Id, CoreArg)] -> ([Id], [CoreArg])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CoreArg)]
prs
force_spec :: Bool
force_spec = (Id -> Bool) -> [Id] -> Bool
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 CoreArg
rhs)
= do { (ScUsage
rhs_usg', CoreArg
rhs') <- ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
env CoreArg
rhs
; (ScUsage, CoreBind) -> UniqSM (ScUsage, CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usage ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
rhs_usg', Id -> CoreArg -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr CoreArg
rhs') }
scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo
scRecRhs :: ScEnv -> (Id, CoreArg) -> UniqSM RhsInfo
scRecRhs ScEnv
env (Id
bndr,CoreArg
rhs)
= do { let ([Id]
arg_bndrs,CoreArg
body) = CoreArg -> ([Id], CoreArg)
forall b. Expr b -> ([b], Expr b)
collectBinders CoreArg
rhs
(ScEnv
body_env, [Id]
arg_bndrs') = HowBound -> ScEnv -> [Id] -> (ScEnv, [Id])
extendBndrsWith HowBound
RecArg ScEnv
env [Id]
arg_bndrs
; (ScUsage
body_usg, CoreArg
body') <- ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
body_env CoreArg
body
; let (ScUsage
rhs_usg, [ArgOcc]
arg_occs) = ScUsage -> [Id] -> (ScUsage, [ArgOcc])
lookupOccs ScUsage
body_usg [Id]
arg_bndrs'
; RhsInfo -> UniqSM RhsInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (RI :: Id -> CoreArg -> ScUsage -> [Id] -> CoreArg -> [ArgOcc] -> RhsInfo
RI { ri_rhs_usg :: ScUsage
ri_rhs_usg = ScUsage
rhs_usg
, ri_fn :: Id
ri_fn = Id
bndr, ri_new_rhs :: CoreArg
ri_new_rhs = [Id] -> CoreArg -> CoreArg
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
arg_bndrs' CoreArg
body'
, ri_lam_bndrs :: [Id]
ri_lam_bndrs = [Id]
arg_bndrs, ri_lam_body :: CoreArg
ri_lam_body = CoreArg
body
, ri_arg_occs :: [ArgOcc]
ri_arg_occs = [ArgOcc]
arg_occs }) }
ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id, CoreArg)]
ruleInfoBinds (RI { ri_fn :: RhsInfo -> Id
ri_fn = Id
fn, ri_new_rhs :: RhsInfo -> CoreArg
ri_new_rhs = CoreArg
new_rhs })
(SI { si_specs :: SpecInfo -> [OneSpec]
si_specs = [OneSpec]
specs })
= [(Id
id,CoreArg
rhs) | OS { os_id :: OneSpec -> Id
os_id = Id
id, os_rhs :: OneSpec -> CoreArg
os_rhs = CoreArg
rhs } <- [OneSpec]
specs] [(Id, CoreArg)] -> [(Id, CoreArg)] -> [(Id, CoreArg)]
forall a. [a] -> [a] -> [a]
++
[(Id
fn Id -> [CoreRule] -> Id
`addIdSpecialisations` [CoreRule]
rules, CoreArg
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 -> CoreArg
ri_new_rhs :: OutExpr
, RhsInfo -> ScUsage
ri_rhs_usg :: ScUsage
, RhsInfo -> [Id]
ri_lam_bndrs :: [InVar]
, RhsInfo -> CoreArg
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 -> ([Id], [CoreArg])
os_pat :: CallPat
, OneSpec -> CoreRule
os_rule :: CoreRule
, OneSpec -> Id
os_id :: OutId
, OneSpec -> CoreArg
os_rhs :: OutExpr }
noSpecInfo :: SpecInfo
noSpecInfo :: SpecInfo
noSpecInfo = SI :: [OneSpec] -> Int -> Maybe ScUsage -> SpecInfo
SI { si_specs :: [OneSpec]
si_specs = [], si_n_specs :: Int
si_n_specs = Int
0, si_mb_unspec :: Maybe ScUsage
si_mb_unspec = Maybe ScUsage
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 = ScUsage -> Maybe ScUsage
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
, (RhsInfo -> Bool) -> [RhsInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> Bool
isExportedId (Id -> Bool) -> (RhsInfo -> Id) -> RhsInfo -> Bool
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 = ScUsage -> Maybe ScUsage
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 = (RhsInfo -> CallEnv -> CallEnv) -> CallEnv -> [RhsInfo] -> CallEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CallEnv -> CallEnv -> CallEnv
combineCalls (CallEnv -> CallEnv -> CallEnv)
-> (RhsInfo -> CallEnv) -> RhsInfo -> CallEnv -> CallEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScUsage -> CallEnv
scu_calls (ScUsage -> CallEnv) -> (RhsInfo -> ScUsage) -> RhsInfo -> CallEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RhsInfo -> ScUsage
ri_rhs_usg) CallEnv
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
| CallEnv -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv CallEnv
seed_calls
=
(ScUsage, [SpecInfo]) -> UniqSM (ScUsage, [SpecInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg_so_far, [SpecInfo]
spec_infos)
| Int
n_iter Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ScEnv -> Int
sc_recursive ScEnv
env
, ScEnv -> Bool
sc_force ScEnv
env Bool -> Bool -> Bool
|| Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing (ScEnv -> Maybe Int
sc_count ScEnv
env)
, (SpecInfo -> Bool) -> [SpecInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
the_limit) (Int -> Bool) -> (SpecInfo -> Int) -> SpecInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecInfo -> Int
si_n_specs) [SpecInfo]
spec_infos
=
(ScUsage, [SpecInfo]) -> UniqSM (ScUsage, [SpecInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg_so_far, [SpecInfo]
spec_infos)
| Bool
otherwise
=
do { [(ScUsage, SpecInfo)]
specs_w_usg <- (RhsInfo -> SpecInfo -> UniqSM (ScUsage, SpecInfo))
-> [RhsInfo] -> [SpecInfo] -> UniqSM [(ScUsage, SpecInfo)]
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) = [(ScUsage, SpecInfo)] -> ([ScUsage], [SpecInfo])
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 Int -> Int -> Int
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 -> CoreArg
ri_lam_body = CoreArg
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
isBottomingId Id
fn
=
(ScUsage, SpecInfo) -> UniqSM (ScUsage, SpecInfo)
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
|| [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
arg_bndrs
=
case Maybe ScUsage
mb_unspec of
Just ScUsage
rhs_usg -> (ScUsage, SpecInfo) -> UniqSM (ScUsage, SpecInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
rhs_usg, SpecInfo
spec_info { si_mb_unspec :: Maybe ScUsage
si_mb_unspec = Maybe ScUsage
forall a. Maybe a
Nothing })
Maybe ScUsage
Nothing -> (ScUsage, SpecInfo) -> UniqSM (ScUsage, SpecInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, SpecInfo
spec_info)
| Just [Call]
all_calls <- CallEnv -> Id -> Maybe [Call]
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv CallEnv
bind_calls Id
fn
=
do { (Bool
boring_call, [([Id], [CoreArg])]
new_pats) <- ScEnv
-> Id
-> SpecInfo
-> [ArgOcc]
-> [Call]
-> UniqSM (Bool, [([Id], [CoreArg])])
callsToNewPats ScEnv
env Id
fn SpecInfo
spec_info [ArgOcc]
arg_occs [Call]
all_calls
; let n_pats :: Int
n_pats = [([Id], [CoreArg])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Id], [CoreArg])]
new_pats
; let spec_env :: ScEnv
spec_env = ScEnv -> Int -> ScEnv
decreaseSpecCount ScEnv
env Int
n_pats
; ([ScUsage]
spec_usgs, [OneSpec]
new_specs) <- ((([Id], [CoreArg]), Int) -> UniqSM (ScUsage, OneSpec))
-> [(([Id], [CoreArg]), Int)] -> UniqSM ([ScUsage], [OneSpec])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (ScEnv
-> Id
-> [Id]
-> CoreArg
-> (([Id], [CoreArg]), Int)
-> UniqSM (ScUsage, OneSpec)
spec_one ScEnv
spec_env Id
fn [Id]
arg_bndrs CoreArg
body)
([([Id], [CoreArg])]
new_pats [([Id], [CoreArg])] -> [Int] -> [(([Id], [CoreArg]), Int)]
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, Maybe ScUsage
forall a. Maybe a
Nothing)
Maybe ScUsage
_ -> (ScUsage
spec_usg, Maybe ScUsage
mb_unspec)
; (ScUsage, SpecInfo) -> UniqSM (ScUsage, SpecInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
new_usg, SI :: [OneSpec] -> Int -> Maybe ScUsage -> SpecInfo
SI { si_specs :: [OneSpec]
si_specs = [OneSpec]
new_specs [OneSpec] -> [OneSpec] -> [OneSpec]
forall a. [a] -> [a] -> [a]
++ [OneSpec]
specs
, si_n_specs :: Int
si_n_specs = Int
spec_count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_pats
, si_mb_unspec :: Maybe ScUsage
si_mb_unspec = Maybe ScUsage
mb_unspec' }) }
| Bool
otherwise
= (ScUsage, SpecInfo) -> UniqSM (ScUsage, SpecInfo)
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]
-> CoreArg
-> (([Id], [CoreArg]), Int)
-> UniqSM (ScUsage, OneSpec)
spec_one ScEnv
env Id
fn [Id]
arg_bndrs CoreArg
body (call_pat :: ([Id], [CoreArg])
call_pat@([Id]
qvars, [CoreArg]
pats), Int
rule_number)
= do { Unique
spec_uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let spec_env :: ScEnv
spec_env = ScEnv -> [(Id, CoreArg)] -> ScEnv
extendScSubstList (ScEnv -> [Id] -> ScEnv
extendScInScope ScEnv
env [Id]
qvars)
([Id]
arg_bndrs [Id] -> [CoreArg] -> [(Id, CoreArg)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreArg]
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:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString OccName
fn_occ String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
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, CoreArg
spec_body) <- ScEnv -> CoreArg -> UniqSM (ScUsage, CoreArg)
scExpr ScEnv
spec_env CoreArg
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 (([Demand], DmdResult) -> [Demand]
forall a b. (a, b) -> a
fst (StrictSig -> ([Demand], DmdResult)
splitStrictSig StrictSig
spec_str)) [Id]
spec_lam_args
spec_join_arity :: Maybe Int
spec_join_arity | Id -> Bool
isJoinId Id
fn = Int -> Maybe Int
forall a. a -> Maybe a
Just ([Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
spec_lam_args)
| Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
spec_id :: Id
spec_id = Name -> Type -> Id
mkLocalIdOrCoVar Name
spec_name
([Id] -> Type -> Type
mkLamTypes [Id]
spec_lam_args Type
body_ty)
Id -> StrictSig -> Id
`setIdStrictness` StrictSig
spec_str
Id -> Int -> Id
`setIdArity` (Id -> Bool) -> [Id] -> Int
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] -> [CoreArg] -> StrictSig
calcSpecStrictness Id
fn [Id]
spec_lam_args [CoreArg]
pats
spec_rhs :: CoreArg
spec_rhs = [Id] -> CoreArg -> CoreArg
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
spec_lam_args_str CoreArg
spec_body
body_ty :: Type
body_ty = CoreArg -> Type
exprType CoreArg
spec_body
rule_rhs :: Expr b
rule_rhs = Expr b -> [Id] -> Expr b
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> Expr b
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]
-> [CoreArg]
-> CoreArg
-> CoreRule
mkRule Module
this_mod Bool
True Bool
True
FastString
rule_name Activation
inline_act Name
fn_name [Id]
qvars [CoreArg]
pats CoreArg
forall b. Expr b
rule_rhs
; (ScUsage, OneSpec) -> UniqSM (ScUsage, OneSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
spec_usg, OS :: ([Id], [CoreArg]) -> CoreRule -> Id -> CoreArg -> OneSpec
OS { os_pat :: ([Id], [CoreArg])
os_pat = ([Id], [CoreArg])
call_pat, os_rule :: CoreRule
os_rule = CoreRule
rule
, os_id :: Id
os_id = Id
spec_id
, os_rhs :: CoreArg
os_rhs = CoreArg
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 Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Demand] -> [Id] -> [Id]
go [Demand]
dmds [Id]
vs
go [Demand]
dmds (Id
v:[Id]
vs) = Id
v Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Demand] -> [Id] -> [Id]
go [Demand]
dmds [Id]
vs
calcSpecStrictness :: Id
-> [Var] -> [CoreExpr]
-> StrictSig
calcSpecStrictness :: Id -> [Id] -> [CoreArg] -> StrictSig
calcSpecStrictness Id
fn [Id]
qvars [CoreArg]
pats
= [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig [Demand]
spec_dmds DmdResult
topRes
where
spec_dmds :: [Demand]
spec_dmds = [ VarEnv Demand -> Id -> Maybe Demand
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Demand
dmd_env Id
qv Maybe Demand -> Demand -> Demand
forall a. Maybe a -> a -> a
`orElse` Demand
topDmd | Id
qv <- [Id]
qvars, Id -> Bool
isId Id
qv ]
StrictSig (DmdType VarEnv Demand
_ [Demand]
dmds DmdResult
_) = Id -> StrictSig
idStrictness Id
fn
dmd_env :: VarEnv Demand
dmd_env = VarEnv Demand -> [Demand] -> [CoreArg] -> VarEnv Demand
go VarEnv Demand
forall a. VarEnv a
emptyVarEnv [Demand]
dmds [CoreArg]
pats
go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv
go :: VarEnv Demand -> [Demand] -> [CoreArg] -> VarEnv Demand
go VarEnv Demand
env [Demand]
ds (Type {} : [CoreArg]
pats) = VarEnv Demand -> [Demand] -> [CoreArg] -> VarEnv Demand
go VarEnv Demand
env [Demand]
ds [CoreArg]
pats
go VarEnv Demand
env [Demand]
ds (Coercion {} : [CoreArg]
pats) = VarEnv Demand -> [Demand] -> [CoreArg] -> VarEnv Demand
go VarEnv Demand
env [Demand]
ds [CoreArg]
pats
go VarEnv Demand
env (Demand
d:[Demand]
ds) (CoreArg
pat : [CoreArg]
pats) = VarEnv Demand -> [Demand] -> [CoreArg] -> VarEnv Demand
go (VarEnv Demand -> Demand -> CoreArg -> VarEnv Demand
go_one VarEnv Demand
env Demand
d CoreArg
pat) [Demand]
ds [CoreArg]
pats
go VarEnv Demand
env [Demand]
_ [CoreArg]
_ = VarEnv Demand
env
go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
go_one :: VarEnv Demand -> Demand -> CoreArg -> VarEnv Demand
go_one VarEnv Demand
env Demand
d (Var Id
v) = (Demand -> Demand -> Demand)
-> VarEnv Demand -> Id -> Demand -> VarEnv Demand
forall a. (a -> a -> a) -> VarEnv a -> Id -> a -> VarEnv a
extendVarEnv_C Demand -> Demand -> Demand
bothDmd VarEnv Demand
env Id
v Demand
d
go_one VarEnv Demand
env Demand
d CoreArg
e
| Just [Demand]
ds <- Demand -> Maybe [Demand]
splitProdDmd_maybe Demand
d
, (Var Id
_, [CoreArg]
args) <- CoreArg -> (CoreArg, [CoreArg])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreArg
e = VarEnv Demand -> [Demand] -> [CoreArg] -> VarEnv Demand
go VarEnv Demand
env [Demand]
ds [CoreArg]
args
go_one VarEnv Demand
env Demand
_ CoreArg
_ = VarEnv Demand
env
type CallPat = ([Var], [CoreExpr])
callsToNewPats :: ScEnv -> Id
-> SpecInfo
-> [ArgOcc] -> [Call]
-> UniqSM (Bool, [CallPat])
callsToNewPats :: ScEnv
-> Id
-> SpecInfo
-> [ArgOcc]
-> [Call]
-> UniqSM (Bool, [([Id], [CoreArg])])
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 ([Id], [CoreArg])]
mb_pats <- (Call -> UniqSM (Maybe ([Id], [CoreArg])))
-> [Call] -> UniqSM [Maybe ([Id], [CoreArg])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe ([Id], [CoreArg]))
callToPats ScEnv
env [ArgOcc]
bndr_occs) [Call]
calls
; let have_boring_call :: Bool
have_boring_call = (Maybe ([Id], [CoreArg]) -> Bool)
-> [Maybe ([Id], [CoreArg])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe ([Id], [CoreArg]) -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe ([Id], [CoreArg])]
mb_pats
good_pats :: [CallPat]
good_pats :: [([Id], [CoreArg])]
good_pats = [Maybe ([Id], [CoreArg])] -> [([Id], [CoreArg])]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ([Id], [CoreArg])]
mb_pats
new_pats :: [([Id], [CoreArg])]
new_pats = (([Id], [CoreArg]) -> Bool)
-> [([Id], [CoreArg])] -> [([Id], [CoreArg])]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ([Id], [CoreArg]) -> Bool
is_done [([Id], [CoreArg])]
good_pats
is_done :: ([Id], [CoreArg]) -> Bool
is_done ([Id], [CoreArg])
p = (OneSpec -> Bool) -> [OneSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (([Id], [CoreArg]) -> ([Id], [CoreArg]) -> Bool
samePat ([Id], [CoreArg])
p (([Id], [CoreArg]) -> Bool)
-> (OneSpec -> ([Id], [CoreArg])) -> OneSpec -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneSpec -> ([Id], [CoreArg])
os_pat) [OneSpec]
done_specs
non_dups :: [([Id], [CoreArg])]
non_dups = (([Id], [CoreArg]) -> ([Id], [CoreArg]) -> Bool)
-> [([Id], [CoreArg])] -> [([Id], [CoreArg])]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy ([Id], [CoreArg]) -> ([Id], [CoreArg]) -> Bool
samePat [([Id], [CoreArg])]
new_pats
small_pats :: [([Id], [CoreArg])]
small_pats = (([Id], [CoreArg]) -> Bool)
-> [([Id], [CoreArg])] -> [([Id], [CoreArg])]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ([Id], [CoreArg]) -> Bool
forall b. ([Id], b) -> Bool
too_big [([Id], [CoreArg])]
non_dups
too_big :: ([Id], b) -> Bool
too_big ([Id]
vars,b
_) = Bool -> Bool
not (DynFlags -> [Id] -> Bool
isWorkerSmallEnough (ScEnv -> DynFlags
sc_dflags ScEnv
env) [Id]
vars)
trimmed_pats :: [([Id], [CoreArg])]
trimmed_pats = ScEnv
-> Id -> SpecInfo -> [([Id], [CoreArg])] -> [([Id], [CoreArg])]
trim_pats ScEnv
env Id
fn SpecInfo
spec_info [([Id], [CoreArg])]
small_pats
; (Bool, [([Id], [CoreArg])]) -> UniqSM (Bool, [([Id], [CoreArg])])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
have_boring_call, [([Id], [CoreArg])]
trimmed_pats) }
trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]
trim_pats :: ScEnv
-> Id -> SpecInfo -> [([Id], [CoreArg])] -> [([Id], [CoreArg])]
trim_pats ScEnv
env Id
fn (SI { si_n_specs :: SpecInfo -> Int
si_n_specs = Int
done_spec_count }) [([Id], [CoreArg])]
pats
| ScEnv -> Bool
sc_force ScEnv
env
Bool -> Bool -> Bool
|| Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
mb_scc
Bool -> Bool -> Bool
|| Int
n_remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n_pats
=
[([Id], [CoreArg])]
pats
| Bool
otherwise
= [([Id], [CoreArg])] -> [([Id], [CoreArg])]
forall p. p -> p
emit_trace ([([Id], [CoreArg])] -> [([Id], [CoreArg])])
-> [([Id], [CoreArg])] -> [([Id], [CoreArg])]
forall a b. (a -> b) -> a -> b
$
Int -> [([Id], [CoreArg])] -> [([Id], [CoreArg])]
forall a. Int -> [a] -> [a]
take Int
n_remaining [([Id], [CoreArg])]
sorted_pats
where
n_pats :: Int
n_pats = [([Id], [CoreArg])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Id], [CoreArg])]
pats
spec_count' :: Int
spec_count' = Int
n_pats Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
done_spec_count
n_remaining :: Int
n_remaining = Int
max_specs Int -> Int -> Int
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 :: [([Id], [CoreArg])]
sorted_pats = ((([Id], [CoreArg]), Int) -> ([Id], [CoreArg]))
-> [(([Id], [CoreArg]), Int)] -> [([Id], [CoreArg])]
forall a b. (a -> b) -> [a] -> [b]
map (([Id], [CoreArg]), Int) -> ([Id], [CoreArg])
forall a b. (a, b) -> a
fst ([(([Id], [CoreArg]), Int)] -> [([Id], [CoreArg])])
-> [(([Id], [CoreArg]), Int)] -> [([Id], [CoreArg])]
forall a b. (a -> b) -> a -> b
$
((([Id], [CoreArg]), Int) -> (([Id], [CoreArg]), Int) -> Ordering)
-> [(([Id], [CoreArg]), Int)] -> [(([Id], [CoreArg]), Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((([Id], [CoreArg]), Int) -> Int)
-> (([Id], [CoreArg]), Int) -> (([Id], [CoreArg]), Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (([Id], [CoreArg]), Int) -> Int
forall a b. (a, b) -> b
snd) ([(([Id], [CoreArg]), Int)] -> [(([Id], [CoreArg]), Int)])
-> [(([Id], [CoreArg]), Int)] -> [(([Id], [CoreArg]), Int)]
forall a b. (a -> b) -> a -> b
$
[(([Id], [CoreArg])
pat, ([Id], [CoreArg]) -> Int
pat_cons ([Id], [CoreArg])
pat) | ([Id], [CoreArg])
pat <- [([Id], [CoreArg])]
pats]
pat_cons :: CallPat -> Int
pat_cons :: ([Id], [CoreArg]) -> Int
pat_cons ([Id]
qs, [CoreArg]
ps) = (CoreArg -> Int -> Int) -> Int -> [CoreArg] -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> Int) -> (CoreArg -> Int) -> CoreArg -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreArg -> Int
forall a b. Num a => Expr b -> a
n_cons) Int
0 [CoreArg]
ps
where
q_set :: VarSet
q_set = [Id] -> VarSet
mkVarSet [Id]
qs
n_cons :: Expr b -> a
n_cons (Var Id
v) | Id
v Id -> VarSet -> Bool
`elemVarSet` VarSet
q_set = a
0
| Bool
otherwise = a
1
n_cons (Cast Expr b
e Coercion
_) = Expr b -> a
n_cons Expr b
e
n_cons (App Expr b
e1 Expr b
e2) = Expr b -> a
n_cons Expr b
e1 a -> a -> a
forall a. Num a => a -> a -> a
+ Expr b -> a
n_cons Expr b
e2
n_cons (Lit {}) = a
1
n_cons Expr b
_ = a
0
emit_trace :: p -> p
emit_trace p
result
| Bool
debugIsOn Bool -> Bool -> Bool
|| DynFlags -> Bool
hasPprDebug (ScEnv -> DynFlags
sc_dflags ScEnv
env)
= String -> SDoc -> p -> p
forall a. String -> SDoc -> a -> a
pprTrace String
"SpecConstr" SDoc
msg p
result
| Bool
otherwise
= p
result
msg :: SDoc
msg = [SDoc] -> SDoc
vcat [ [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
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
<+> [([Id], [CoreArg])] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int -> [([Id], [CoreArg])] -> [([Id], [CoreArg])]
forall a. Int -> [a] -> [a]
drop Int
n_remaining [([Id], [CoreArg])]
sorted_pats) ]
callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe ([Id], [CoreArg]))
callToPats ScEnv
env [ArgOcc]
bndr_occs call :: Call
call@(Call Id
_ [CoreArg]
args ValueEnv
con_env)
| [CoreArg]
args [CoreArg] -> [ArgOcc] -> Bool
forall a b. [a] -> [b] -> Bool
`ltLength` [ArgOcc]
bndr_occs
= Maybe ([Id], [CoreArg]) -> UniqSM (Maybe ([Id], [CoreArg]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([Id], [CoreArg])
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, [CoreArg]
pats) <- ScEnv
-> InScopeSet
-> ValueEnv
-> [CoreArg]
-> [ArgOcc]
-> UniqSM (Bool, [CoreArg])
argsToPats ScEnv
env InScopeSet
in_scope ValueEnv
con_env [CoreArg]
args [ArgOcc]
bndr_occs
; let pat_fvs :: [Id]
pat_fvs = [CoreArg] -> [Id]
exprsFreeVarsList [CoreArg]
pats
in_scope_vars :: VarSet
in_scope_vars = InScopeSet -> VarSet
getInScopeVars InScopeSet
in_scope
is_in_scope :: Id -> Bool
is_in_scope Id
v = Id
v Id -> VarSet -> Bool
`elemVarSet` VarSet
in_scope_vars
qvars :: [Id]
qvars = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Id -> Bool
is_in_scope [Id]
pat_fvs
([Id]
ktvs, [Id]
ids) = (Id -> Bool) -> [Id] -> ([Id], [Id])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Id -> Bool
isTyVar [Id]
qvars
qvars' :: [Id]
qvars' = [Id] -> [Id]
scopedSort [Id]
ktvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
sanitise [Id]
ids
sanitise :: Id -> Id
sanitise Id
id = Id
id Id -> Type -> Id
`setIdType` Type -> Type
expandTypeSynonyms (Id -> Type
idType Id
id)
bad_covars :: CoVarSet
bad_covars :: VarSet
bad_covars = (CoreArg -> VarSet) -> [CoreArg] -> VarSet
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet CoreArg -> VarSet
get_bad_covars [CoreArg]
pats
get_bad_covars :: CoreArg -> CoVarSet
get_bad_covars :: CoreArg -> VarSet
get_bad_covars (Type Type
ty)
= (Id -> Bool) -> VarSet -> VarSet
filterVarSet (\Id
v -> Id -> Bool
isId Id
v Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
is_in_scope Id
v)) (VarSet -> VarSet) -> VarSet -> VarSet
forall a b. (a -> b) -> a -> b
$
Type -> VarSet
tyCoVarsOfType Type
ty
get_bad_covars CoreArg
_
= VarSet
emptyVarSet
;
WARN( not (isEmptyVarSet bad_covars)
, text "SpecConstr: bad covars:" <+> ppr bad_covars
$$ ppr call )
if Bool
interesting Bool -> Bool -> Bool
&& VarSet -> Bool
isEmptyVarSet VarSet
bad_covars
then Maybe ([Id], [CoreArg]) -> UniqSM (Maybe ([Id], [CoreArg]))
forall (m :: * -> *) a. Monad m => a -> m a
return (([Id], [CoreArg]) -> Maybe ([Id], [CoreArg])
forall a. a -> Maybe a
Just ([Id]
qvars', [CoreArg]
pats))
else Maybe ([Id], [CoreArg]) -> UniqSM (Maybe ([Id], [CoreArg]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([Id], [CoreArg])
forall a. Maybe a
Nothing }
argToPat :: ScEnv
-> InScopeSet
-> ValueEnv
-> CoreArg
-> ArgOcc
-> UniqSM (Bool, CoreArg)
argToPat :: ScEnv
-> InScopeSet
-> ValueEnv
-> CoreArg
-> ArgOcc
-> UniqSM (Bool, CoreArg)
argToPat ScEnv
_env InScopeSet
_in_scope ValueEnv
_val_env arg :: CoreArg
arg@(Type {}) ArgOcc
_arg_occ
= (Bool, CoreArg) -> UniqSM (Bool, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, CoreArg
arg)
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Tick Tickish Id
_ CoreArg
arg) ArgOcc
arg_occ
= ScEnv
-> InScopeSet
-> ValueEnv
-> CoreArg
-> ArgOcc
-> UniqSM (Bool, CoreArg)
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env CoreArg
arg ArgOcc
arg_occ
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Let CoreBind
_ CoreArg
arg) ArgOcc
arg_occ
= ScEnv
-> InScopeSet
-> ValueEnv
-> CoreArg
-> ArgOcc
-> UniqSM (Bool, CoreArg)
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env CoreArg
arg ArgOcc
arg_occ
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Cast CoreArg
arg Coercion
co) ArgOcc
arg_occ
| Bool -> Bool
not (ScEnv -> Type -> Bool
ignoreType ScEnv
env Type
ty2)
= do { (Bool
interesting, CoreArg
arg') <- ScEnv
-> InScopeSet
-> ValueEnv
-> CoreArg
-> ArgOcc
-> UniqSM (Bool, CoreArg)
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env CoreArg
arg ArgOcc
arg_occ
; if Bool -> Bool
not Bool
interesting then
Type -> UniqSM (Bool, CoreArg)
wildCardPat Type
ty2
else do
{
Unique
uniq <- UniqSM Unique
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)
; (Bool, CoreArg) -> UniqSM (Bool, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
interesting, CoreArg -> Coercion -> CoreArg
forall b. Expr b -> Coercion -> Expr b
Cast CoreArg
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 CoreArg
arg ArgOcc
arg_occ
| Just (ConVal (DataAlt DataCon
dc) [CoreArg]
args) <- ValueEnv -> CoreArg -> Maybe Value
isValue ValueEnv
val_env CoreArg
arg
, Bool -> Bool
not (ScEnv -> DataCon -> Bool
ignoreDataCon ScEnv
env DataCon
dc)
, Just [ArgOcc]
arg_occs <- DataCon -> Maybe [ArgOcc]
forall key. Uniquable key => key -> Maybe [ArgOcc]
mb_scrut DataCon
dc
= do { let ([CoreArg]
ty_args, [CoreArg]
rest_args) = [Id] -> [CoreArg] -> ([CoreArg], [CoreArg])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList (DataCon -> [Id]
dataConUnivTyVars DataCon
dc) [CoreArg]
args
; (Bool
_, [CoreArg]
args') <- ScEnv
-> InScopeSet
-> ValueEnv
-> [CoreArg]
-> [ArgOcc]
-> UniqSM (Bool, [CoreArg])
argsToPats ScEnv
env InScopeSet
in_scope ValueEnv
val_env [CoreArg]
rest_args [ArgOcc]
arg_occs
; (Bool, CoreArg) -> UniqSM (Bool, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,
DataCon -> [CoreArg] -> CoreArg
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
dc ([CoreArg]
ty_args [CoreArg] -> [CoreArg] -> [CoreArg]
forall a. [a] -> [a] -> [a]
++ [CoreArg]
args')) }
where
mb_scrut :: key -> Maybe [ArgOcc]
mb_scrut key
dc = case ArgOcc
arg_occ of
ScrutOcc DataConEnv [ArgOcc]
bs | Just [ArgOcc]
occs <- DataConEnv [ArgOcc] -> key -> Maybe [ArgOcc]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM DataConEnv [ArgOcc]
bs key
dc
-> [ArgOcc] -> Maybe [ArgOcc]
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
-> [ArgOcc] -> Maybe [ArgOcc]
forall a. a -> Maybe a
Just (ArgOcc -> [ArgOcc]
forall a. a -> [a]
repeat ArgOcc
UnkOcc)
| Bool
otherwise
-> Maybe [ArgOcc]
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))
= (Bool, CoreArg) -> UniqSM (Bool, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Id -> CoreArg
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
&& Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust (ValueEnv -> Id -> Maybe Value
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 CoreArg
arg ArgOcc
_arg_occ
= Type -> UniqSM (Bool, CoreArg)
wildCardPat (CoreArg -> Type
exprType CoreArg
arg)
wildCardPat :: Type -> UniqSM (Bool, CoreArg)
wildCardPat :: Type -> UniqSM (Bool, CoreArg)
wildCardPat Type
ty
= do { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let id :: Id
id = FastString -> Unique -> Type -> Id
mkSysLocalOrCoVar (String -> FastString
fsLit String
"sc") Unique
uniq Type
ty
; (Bool, CoreArg) -> UniqSM (Bool, CoreArg)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Id -> CoreArg
forall b. Id -> Expr b
varToCoreExpr Id
id) }
argsToPats :: ScEnv -> InScopeSet -> ValueEnv
-> [CoreArg] -> [ArgOcc]
-> UniqSM (Bool, [CoreArg])
argsToPats :: ScEnv
-> InScopeSet
-> ValueEnv
-> [CoreArg]
-> [ArgOcc]
-> UniqSM (Bool, [CoreArg])
argsToPats ScEnv
env InScopeSet
in_scope ValueEnv
val_env [CoreArg]
args [ArgOcc]
occs
= do { [(Bool, CoreArg)]
stuff <- (CoreArg -> ArgOcc -> UniqSM (Bool, CoreArg))
-> [CoreArg] -> [ArgOcc] -> UniqSM [(Bool, CoreArg)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (ScEnv
-> InScopeSet
-> ValueEnv
-> CoreArg
-> ArgOcc
-> UniqSM (Bool, CoreArg)
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env) [CoreArg]
args [ArgOcc]
occs
; let ([Bool]
interesting_s, [CoreArg]
args') = [(Bool, CoreArg)] -> ([Bool], [CoreArg])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Bool, CoreArg)]
stuff
; (Bool, [CoreArg]) -> UniqSM (Bool, [CoreArg])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
interesting_s, [CoreArg]
args') }
isValue :: ValueEnv -> CoreExpr -> Maybe Value
isValue :: ValueEnv -> CoreArg -> Maybe Value
isValue ValueEnv
_env (Lit Literal
lit)
| Literal -> Bool
litIsLifted Literal
lit = Maybe Value
forall a. Maybe a
Nothing
| Bool
otherwise = Value -> Maybe Value
forall a. a -> Maybe a
Just (AltCon -> [CoreArg] -> Value
ConVal (Literal -> AltCon
LitAlt Literal
lit) [])
isValue ValueEnv
env (Var Id
v)
| Just Value
cval <- ValueEnv -> Id -> Maybe Value
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv ValueEnv
env Id
v
= Value -> Maybe Value
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 -> CoreArg -> Maybe Value
isValue ValueEnv
env (Unfolding -> CoreArg
unfoldingTemplate Unfolding
unf)
where
unf :: Unfolding
unf = Id -> Unfolding
idUnfolding Id
v
isValue ValueEnv
env (Lam Id
b CoreArg
e)
| Id -> Bool
isTyVar Id
b = case ValueEnv -> CoreArg -> Maybe Value
isValue ValueEnv
env CoreArg
e of
Just Value
_ -> Value -> Maybe Value
forall a. a -> Maybe a
Just Value
LambdaVal
Maybe Value
Nothing -> Maybe Value
forall a. Maybe a
Nothing
| Bool
otherwise = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
LambdaVal
isValue ValueEnv
env (Tick Tickish Id
t CoreArg
e)
| Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
t)
= ValueEnv -> CoreArg -> Maybe Value
isValue ValueEnv
env CoreArg
e
isValue ValueEnv
_env CoreArg
expr
| (Var Id
fun, [CoreArg]
args, [Tickish Id]
_) <- (Tickish Id -> Bool)
-> CoreArg -> (CoreArg, [CoreArg], [Tickish Id])
forall b.
(Tickish Id -> Bool) -> Expr b -> (Expr b, [Expr b], [Tickish Id])
collectArgsTicks (Bool -> Bool
not (Bool -> Bool) -> (Tickish Id -> Bool) -> Tickish Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode) CoreArg
expr
= case Id -> Maybe DataCon
isDataConWorkId_maybe Id
fun of
Just DataCon
con | [CoreArg]
args [CoreArg] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` DataCon -> Int
dataConRepArity DataCon
con
-> Value -> Maybe Value
forall a. a -> Maybe a
Just (AltCon -> [CoreArg] -> Value
ConVal (DataCon -> AltCon
DataAlt DataCon
con) [CoreArg]
args)
Maybe DataCon
_other | [CoreArg] -> Int
forall b. [Arg b] -> Int
valArgCount [CoreArg]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Id -> Int
idArity Id
fun
-> Value -> Maybe Value
forall a. a -> Maybe a
Just Value
LambdaVal
Maybe DataCon
_other -> Maybe Value
forall a. Maybe a
Nothing
isValue ValueEnv
_env CoreArg
_expr = Maybe Value
forall a. Maybe a
Nothing
valueIsWorkFree :: Value -> Bool
valueIsWorkFree :: Value -> Bool
valueIsWorkFree Value
LambdaVal = Bool
True
valueIsWorkFree (ConVal AltCon
_ [CoreArg]
args) = (CoreArg -> Bool) -> [CoreArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CoreArg -> Bool
exprIsWorkFree [CoreArg]
args
samePat :: CallPat -> CallPat -> Bool
samePat :: ([Id], [CoreArg]) -> ([Id], [CoreArg]) -> Bool
samePat ([Id]
vs1, [CoreArg]
as1) ([Id]
vs2, [CoreArg]
as2)
= (CoreArg -> CoreArg -> Bool) -> [CoreArg] -> [CoreArg] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
all2 CoreArg -> CoreArg -> Bool
forall b b.
(OutputableBndr b, OutputableBndr b) =>
Expr b -> Expr b -> Bool
same [CoreArg]
as1 [CoreArg]
as2
where
same :: Expr b -> Expr b -> Bool
same (Var Id
v1) (Var Id
v2)
| Id
v1 Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
vs1 = Id
v2 Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
vs2
| Id
v2 Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
vs2 = Bool
False
| Bool
otherwise = Id
v1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v2
same (Lit Literal
l1) (Lit Literal
l2) = Literal
l1Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
==Literal
l2
same (App Expr b
f1 Expr b
a1) (App Expr b
f2 Expr b
a2) = Expr b -> Expr b -> Bool
same Expr b
f1 Expr b
f2 Bool -> Bool -> Bool
&& Expr b -> Expr b -> Bool
same Expr b
a1 Expr b
a2
same (Type {}) (Type {}) = Bool
True
same (Coercion {}) (Coercion {}) = Bool
True
same (Tick Tickish Id
_ Expr b
e1) Expr b
e2 = Expr b -> Expr b -> Bool
same Expr b
e1 Expr b
e2
same (Cast Expr b
e1 Coercion
_) Expr b
e2 = Expr b -> Expr b -> Bool
same Expr b
e1 Expr b
e2
same Expr b
e1 (Tick Tickish Id
_ Expr b
e2) = Expr b -> Expr b -> Bool
same Expr b
e1 Expr b
e2
same Expr b
e1 (Cast Expr b
e2 Coercion
_) = Expr b -> Expr b -> Bool
same Expr b
e1 Expr b
e2
same Expr b
e1 Expr b
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