{-# LANGUAGE CPP, LambdaCase #-}
#if __GLASGOW_HASKELL__ < 905
{-# LANGUAGE PatternSynonyms #-}
#endif
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.SpecConstr(
specConstrProgram,
SpecConstrAnnotation(..),
SpecFailWarning(..)
) where
import GHC.Prelude
import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )
, gopt, hasPprDebug )
import GHC.Core
import GHC.Core.Subst
import GHC.Core.Utils
import GHC.Core.Unfold
import GHC.Core.Opt.Simplify.Inline
import GHC.Core.FVs ( exprsFreeVarsList, exprFreeVars )
import GHC.Core.Opt.Monad
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Core.Opt.OccurAnal( BinderSwapDecision(..), scrutOkForBinderSwap )
import GHC.Core.DataCon
import GHC.Core.Class( classTyVars )
import GHC.Core.Coercion hiding( substCo )
import GHC.Core.Rules
import GHC.Core.Predicate ( typeDeterminesValue )
import GHC.Core.Type hiding ( substTy )
import GHC.Core.TyCon (TyCon, tyConName )
import GHC.Core.Multiplicity
import GHC.Core.Ppr ( pprParendExpr )
import GHC.Core.Make ( mkImpossibleExpr )
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
import GHC.Types.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..))
import GHC.Types.Literal ( litIsLifted )
import GHC.Types.Id
import GHC.Types.Id.Info ( IdDetails(..) )
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Tickish
import GHC.Types.Basic
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.Unique.Supply
import GHC.Types.Unique.FM
import GHC.Types.Unique( hasKey )
import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing )
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Monad
import GHC.Builtin.Names ( specTyConKey )
import GHC.Exts( SpecConstrAnnotation(..) )
import GHC.Serialized ( deserializeWithData )
import Control.Monad
import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL )
import Data.Maybe( mapMaybe )
import Data.Ord( comparing )
import Data.Tuple
specConstrProgram :: ModGuts -> CoreM ModGuts
specConstrProgram :: ModGuts -> CoreM ModGuts
specConstrProgram ModGuts
guts
= do { env0 <- ModGuts -> CoreM ScEnv
initScEnv ModGuts
guts
; us <- getUniqueSupplyM
; let (_usg, binds', warnings) = initUs_ us $
scTopBinds env0 (mg_binds guts)
; when (not (null warnings)) $ msg specConstr_warn_class (warn_msg warnings)
; return (guts { mg_binds = binds' }) }
where
specConstr_warn_class :: MessageClass
specConstr_warn_class = Severity
-> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic Severity
SevWarning (DiagnosticReason -> ResolvedDiagnosticReason
ResolvedDiagnosticReason DiagnosticReason
WarningWithoutFlag) Maybe DiagnosticCode
forall a. Maybe a
Nothing
warn_msg :: SpecFailWarnings -> SDoc
warn_msg :: [SpecFailWarning] -> SDoc
warn_msg [SpecFailWarning]
warnings = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SpecConstr encountered one or more function(s) with a SPEC argument that resulted in too many arguments," SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"which resulted in no specialization being generated for these functions:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((SpecFailWarning -> SDoc) -> [SpecFailWarning] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map SpecFailWarning -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SpecFailWarning]
warnings)) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"If this is expected you might want to increase -fmax-forced-spec-args to force specialization anyway.")
scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind], [SpecFailWarning])
scTopBinds :: ScEnv
-> [OutBind] -> UniqSM (ScUsage, [OutBind], [SpecFailWarning])
scTopBinds ScEnv
_env [] = (ScUsage, [OutBind], [SpecFailWarning])
-> UniqSM (ScUsage, [OutBind], [SpecFailWarning])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, [], [])
scTopBinds ScEnv
env (OutBind
b:[OutBind]
bs) = do { (usg, b', bs', warnings) <- TopLevelFlag
-> ScEnv
-> OutBind
-> (ScEnv -> UniqSM (ScUsage, [OutBind], [SpecFailWarning]))
-> UniqSM (ScUsage, [OutBind], [OutBind], [SpecFailWarning])
forall a.
TopLevelFlag
-> ScEnv
-> OutBind
-> (ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning]))
-> UniqSM (ScUsage, [OutBind], a, [SpecFailWarning])
scBind TopLevelFlag
TopLevel ScEnv
env OutBind
b ((ScEnv -> UniqSM (ScUsage, [OutBind], [SpecFailWarning]))
-> UniqSM (ScUsage, [OutBind], [OutBind], [SpecFailWarning]))
-> (ScEnv -> UniqSM (ScUsage, [OutBind], [SpecFailWarning]))
-> UniqSM (ScUsage, [OutBind], [OutBind], [SpecFailWarning])
forall a b. (a -> b) -> a -> b
$
(\ScEnv
env -> ScEnv
-> [OutBind] -> UniqSM (ScUsage, [OutBind], [SpecFailWarning])
scTopBinds ScEnv
env [OutBind]
bs)
; return (usg, b' ++ bs', warnings) }
data SpecConstrOpts = SpecConstrOpts
{ SpecConstrOpts -> Int
sc_max_args :: !Int
, SpecConstrOpts -> Int
sc_max_forced_args :: !Int
, SpecConstrOpts -> Bool
sc_debug :: !Bool
, SpecConstrOpts -> UnfoldingOpts
sc_uf_opts :: !UnfoldingOpts
, SpecConstrOpts -> Module
sc_module :: !Module
, SpecConstrOpts -> Maybe Int
sc_size :: !(Maybe Int)
, SpecConstrOpts -> Maybe Int
sc_count :: !(Maybe Int)
, SpecConstrOpts -> Int
sc_recursive :: !Int
, SpecConstrOpts -> Bool
sc_keen :: !Bool
}
data ScEnv = SCE { ScEnv -> SpecConstrOpts
sc_opts :: !SpecConstrOpts,
ScEnv -> Bool
sc_force :: Bool,
ScEnv -> Subst
sc_subst :: Subst,
ScEnv -> HowBoundEnv
sc_how_bound :: HowBoundEnv,
ScEnv -> ValueEnv
sc_vals :: ValueEnv,
ScEnv -> UniqFM Name SpecConstrAnnotation
sc_annotations :: UniqFM Name SpecConstrAnnotation
}
type HowBoundEnv = VarEnv HowBound
type ValueEnv = IdEnv Value
data Value = ConVal
Bool
AltCon
[CoreArg]
| LambdaVal
instance Outputable Value where
ppr :: Value -> SDoc
ppr Value
LambdaVal = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<Lambda>"
ppr (ConVal Bool
wf AltCon
con [Expr Id]
args)
| [Expr Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr Id]
args = AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
con
| Bool
otherwise = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
con SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces SDoc
pp_wf SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Expr Id] -> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [Expr Id]
args)
where
pp_wf :: SDoc
pp_wf | Bool
wf = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"wf"
| Bool
otherwise = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"not-wf"
initScOpts :: DynFlags -> Module -> SpecConstrOpts
initScOpts :: DynFlags -> Module -> SpecConstrOpts
initScOpts DynFlags
dflags Module
this_mod = SpecConstrOpts
{ sc_max_args :: Int
sc_max_args = DynFlags -> Int
maxWorkerArgs DynFlags
dflags,
sc_max_forced_args :: Int
sc_max_forced_args = DynFlags -> Int
maxForcedSpecArgs DynFlags
dflags,
sc_debug :: Bool
sc_debug = DynFlags -> Bool
hasPprDebug 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
}
initScEnv :: ModGuts -> CoreM ScEnv
initScEnv :: ModGuts -> CoreM ScEnv
initScEnv ModGuts
guts
= do { dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; (_, anns) <- getFirstAnnotations deserializeWithData guts
; this_mod <- getModule
; return (SCE { sc_opts = initScOpts dflags this_mod,
sc_force = False,
sc_subst = init_subst,
sc_how_bound = emptyVarEnv,
sc_vals = emptyVarEnv,
sc_annotations = anns }) }
where
init_subst :: Subst
init_subst = InScopeSet -> Subst
mkEmptySubst (InScopeSet -> Subst) -> InScopeSet -> Subst
forall a b. (a -> b) -> a -> b
$ [OutBind] -> InScopeSet
mkInScopeSetBndrs (ModGuts -> [OutBind]
mg_binds ModGuts
guts)
data HowBound = RecFun
| RecArg
instance Outputable HowBound where
ppr :: HowBound -> SDoc
ppr HowBound
RecFun = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RecFun"
ppr HowBound
RecArg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RecArg"
scForce :: ScEnv -> Bool -> ScEnv
scForce :: ScEnv -> Bool -> ScEnv
scForce ScEnv
env Bool
b = ScEnv
env { sc_force = b }
lookupHowBound :: ScEnv -> OutId -> 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 -> InId -> OutExpr
scSubstId :: ScEnv -> Id -> Expr Id
scSubstId ScEnv
env Id
v = HasDebugCallStack => Subst -> Id -> Expr Id
Subst -> Id -> Expr Id
lookupIdSubst (ScEnv -> Subst
sc_subst ScEnv
env) Id
v
#if !(MIN_VERSION_base(4, 16, 0))
data Solo a = Solo a
#endif
#if __GLASGOW_HASKELL__ < 905
pattern MkSolo :: a -> Solo a
pattern MkSolo a = Solo a
#endif
scSubstTy :: ScEnv -> InType -> Solo OutType
scSubstTy :: ScEnv -> InType -> Solo InType
scSubstTy ScEnv
env InType
ty =
let !subst :: Subst
subst = ScEnv -> Subst
sc_subst ScEnv
env
in InType -> Solo InType
forall a. a -> Solo a
MkSolo (Subst -> InType -> InType
substTyUnchecked Subst
subst InType
ty)
scSubstCo :: ScEnv -> Coercion -> Coercion
scSubstCo :: ScEnv -> Coercion -> Coercion
scSubstCo ScEnv
env Coercion
co = HasDebugCallStack => 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 = zapSubst (sc_subst env) }
extendScInScope :: ScEnv -> [Var] -> ScEnv
extendScInScope :: ScEnv -> [Id] -> ScEnv
extendScInScope ScEnv
env [Id]
qvars
= ScEnv
env { sc_subst = extendSubstInScopeList (sc_subst env) qvars }
extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
extendScSubst :: ScEnv -> Id -> Expr Id -> ScEnv
extendScSubst ScEnv
env Id
var Expr Id
expr = ScEnv
env { sc_subst = extendSubst (sc_subst env) var expr }
extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
extendScSubstList :: ScEnv -> [(Id, Expr Id)] -> ScEnv
extendScSubstList ScEnv
env [(Id, Expr Id)]
prs = ScEnv
env { sc_subst = extendSubstList (sc_subst env) prs }
extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
extendHowBound :: ScEnv -> [Id] -> HowBound -> ScEnv
extendHowBound ScEnv
env [Id]
bndrs HowBound
how_bound
= ScEnv
env { sc_how_bound = extendVarEnvList (sc_how_bound env)
[(bndr,how_bound) | bndr <- 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_how_bound = hb_env' }, [Id]
bndrs')
where
(Subst
subst', [Id]
bndrs') = Subst -> [Id] -> (Subst, [Id])
forall (f :: * -> *).
Traversable f =>
Subst -> f Id -> (Subst, f 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_how_bound = 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' }, [Id]
bndrs')
where
(Subst
subst', [Id]
bndrs') = Subst -> [Id] -> (Subst, [Id])
forall (f :: * -> *).
Traversable f =>
Subst -> f Id -> (Subst, f Id)
substRecBndrs (ScEnv -> Subst
sc_subst ScEnv
env) [Id]
bndrs
extendBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
extendBndrs :: ScEnv -> [Id] -> (ScEnv, [Id])
extendBndrs ScEnv
env [Id]
bndrs = (ScEnv -> Id -> (ScEnv, Id)) -> ScEnv -> [Id] -> (ScEnv, [Id])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env [Id]
bndrs
extendBndr :: ScEnv -> Var -> (ScEnv, Var)
extendBndr :: ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env Id
bndr = (ScEnv
env { sc_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
id Maybe Value
mb_val
= case Maybe Value
mb_val of
Maybe Value
Nothing -> ScEnv
env
Just Value
cv -> ScEnv
env { sc_vals = extendVarEnv (sc_vals env) id cv }
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 | DoBinderSwap Id
v MCoercion
mco <- Expr Id -> BinderSwapDecision
scrutOkForBinderSwap Expr Id
scrut
, MCoercion -> Bool
isReflMCo MCoercion
mco = 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 }
= (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 (Bool -> AltCon -> [Expr Id] -> Value
ConVal Bool
True AltCon
con [])
DataAlt {} -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Bool -> AltCon -> [Expr Id] -> Value
ConVal Bool
True AltCon
con [Expr Id]
vanilla_args)
where
vanilla_args :: [Expr Id]
vanilla_args = (InType -> Expr Id) -> [InType] -> [Expr Id]
forall a b. (a -> b) -> [a] -> [b]
map InType -> Expr Id
forall b. InType -> Expr b
Type (HasDebugCallStack => InType -> [InType]
InType -> [InType]
tyConAppArgs (Id -> InType
idType Id
case_bndr)) [Expr Id] -> [Expr Id] -> [Expr Id]
forall a. [a] -> [a] -> [a]
++
[Id] -> [Expr Id]
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 = False
, sc_opts = opts { sc_count = case sc_count opts of
Maybe Int
Nothing -> Maybe Int
forall a. Maybe a
Nothing
Just Int
n -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$! Int -> Int
forall {a}. Integral a => a -> a
dec Int
n
}
}
where
opts :: SpecConstrOpts
opts = ScEnv -> SpecConstrOpts
sc_opts ScEnv
env
dec :: a -> a
dec a
n = a
n a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
2
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 -> InType -> Bool
ignoreType ScEnv
env InType
ty
= case InType -> Maybe TyCon
tyConAppTyCon_maybe InType
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 Name SpecConstrAnnotation
-> Name -> Maybe SpecConstrAnnotation
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (ScEnv -> UniqFM Name SpecConstrAnnotation
sc_annotations ScEnv
env) (TyCon -> Name
tyConName 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 -> InType -> Bool
forceSpecFunTy ScEnv
env (InType -> Bool) -> (Id -> InType) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Id], InType) -> InType
forall a b. (a, b) -> b
snd (([Id], InType) -> InType)
-> (Id -> ([Id], InType)) -> Id -> InType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InType -> ([Id], InType)
splitForAllTyCoVars (InType -> ([Id], InType))
-> (Id -> InType) -> Id -> ([Id], InType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> InType
varType (Id -> Bool) -> Id -> Bool
forall a b. (a -> b) -> a -> b
$ Id
var
forceSpecFunTy :: ScEnv -> Type -> Bool
forceSpecFunTy :: ScEnv -> InType -> Bool
forceSpecFunTy ScEnv
env = (InType -> Bool) -> [InType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ScEnv -> InType -> Bool
forceSpecArgTy ScEnv
env) ([InType] -> Bool) -> (InType -> [InType]) -> InType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scaled InType -> InType) -> [Scaled InType] -> [InType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled InType -> InType
forall a. Scaled a -> a
scaledThing ([Scaled InType] -> [InType])
-> (InType -> [Scaled InType]) -> InType -> [InType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Scaled InType], InType) -> [Scaled InType]
forall a b. (a, b) -> a
fst (([Scaled InType], InType) -> [Scaled InType])
-> (InType -> ([Scaled InType], InType))
-> InType
-> [Scaled InType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InType -> ([Scaled InType], InType)
splitFunTys
forceSpecArgTy :: ScEnv -> Type -> Bool
forceSpecArgTy :: ScEnv -> InType -> Bool
forceSpecArgTy ScEnv
env InType
ty
| InType -> Bool
isFunTy InType
ty
= Bool
False
| Just (TyCon
tycon, [InType]
tys) <- HasDebugCallStack => InType -> Maybe (TyCon, [InType])
InType -> Maybe (TyCon, [InType])
splitTyConApp_maybe InType
ty
= TyCon
tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
specTyConKey
Bool -> Bool -> Bool
|| UniqFM Name SpecConstrAnnotation
-> Name -> Maybe SpecConstrAnnotation
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (ScEnv -> UniqFM Name SpecConstrAnnotation
sc_annotations ScEnv
env) (TyCon -> Name
tyConName 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
|| (InType -> Bool) -> [InType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ScEnv -> InType -> Bool
forceSpecArgTy ScEnv
env) [InType]
tys
forceSpecArgTy ScEnv
_ InType
_ = Bool
False
data ScUsage
= SCU {
ScUsage -> CallEnv
scu_calls :: CallEnv,
ScUsage -> IdEnv ArgOcc
scu_occs :: !(IdEnv ArgOcc)
}
type CallEnv = IdEnv [Call]
data Call = Call OutId [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
forall doc. IsLine doc => String -> doc
text String
"SCU" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"calls =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CallEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr CallEnv
calls
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"occs =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> IdEnv ArgOcc -> 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
_) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep ((Expr Id -> SDoc) -> [Expr Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Expr Id -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprParendExpr [Expr Id]
args)
nullUsage :: ScUsage
nullUsage :: ScUsage
nullUsage = 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]
(++)
delCallsFor :: ScUsage -> [Var] -> ScUsage
delCallsFor :: ScUsage -> [Id] -> ScUsage
delCallsFor ScUsage
env [Id]
bndrs = ScUsage
env { scu_calls = scu_calls env `delVarEnvList` bndrs }
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 = (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 a. (a -> a -> a) -> [a] -> a
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 = 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])
deadArgOcc :: ArgOcc -> Bool
deadArgOcc :: ArgOcc -> Bool
deadArgOcc (ScrutOcc {}) = Bool
False
deadArgOcc ArgOcc
UnkOcc = Bool
False
deadArgOcc ArgOcc
NoOcc = Bool
True
specialisableArgOcc :: ArgOcc -> Bool
specialisableArgOcc :: ArgOcc -> Bool
specialisableArgOcc ArgOcc
UnkOcc = Bool
False
specialisableArgOcc ArgOcc
NoOcc = Bool
False
specialisableArgOcc (ScrutOcc {}) = Bool
True
instance Outputable ArgOcc where
ppr :: ArgOcc -> SDoc
ppr (ScrutOcc DataConEnv [ArgOcc]
xs) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"scrut-occ" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> DataConEnv [ArgOcc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataConEnv [ArgOcc]
xs
ppr ArgOcc
UnkOcc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unk-occ"
ppr ArgOcc
NoOcc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"no-occ"
evalScrutOcc :: ArgOcc
evalScrutOcc :: ArgOcc
evalScrutOcc = DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc DataConEnv [ArgOcc]
forall {k} (key :: k) 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 (([ArgOcc] -> [ArgOcc] -> [ArgOcc])
-> DataConEnv [ArgOcc]
-> DataConEnv [ArgOcc]
-> DataConEnv [ArgOcc]
forall {k} elt (key :: k).
(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 = String
-> (ArgOcc -> ArgOcc -> ArgOcc) -> [ArgOcc] -> [ArgOcc] -> [ArgOcc]
forall a b c.
HasDebugCallStack =>
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 = extendVarEnv (scu_occs usg) v occ }
| Bool
otherwise = ScUsage
usg
setScrutOcc ScEnv
_env ScUsage
usg Expr Id
_other ArgOcc
_occ
= ScUsage
usg
scBind :: TopLevelFlag -> ScEnv -> InBind
-> (ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning]))
-> UniqSM (ScUsage, [OutBind], a, [SpecFailWarning])
scBind :: forall a.
TopLevelFlag
-> ScEnv
-> OutBind
-> (ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning]))
-> UniqSM (ScUsage, [OutBind], a, [SpecFailWarning])
scBind TopLevelFlag
top_lvl ScEnv
env (NonRec Id
bndr Expr Id
rhs) ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning])
do_body
| Id -> Bool
isTyVar Id
bndr
= do { (final_usage, body', warnings) <- ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning])
do_body (ScEnv -> Id -> Expr Id -> ScEnv
extendScSubst ScEnv
env Id
bndr Expr Id
rhs)
; return (final_usage, [], body', warnings) }
| Bool -> Bool
not (TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl)
= do { let (ScEnv
body_env, Id
bndr') = ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env Id
bndr
; (rhs_info, rhs_ws) <- ScEnv -> (Id, Expr Id) -> UniqSM (RhsInfo, [SpecFailWarning])
scRecRhs ScEnv
env (Id
bndr',Expr Id
rhs)
; let body_env2 = ScEnv -> [Id] -> HowBound -> ScEnv
extendHowBound ScEnv
body_env [Id
bndr'] HowBound
RecFun
rhs' = RhsInfo -> Expr Id
ri_new_rhs RhsInfo
rhs_info
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')
; (body_usg, body', warnings_body) <- do_body body_env3
; (spec_usg, specs, warnings_bnd) <- specNonRec env (scu_calls body_usg) rhs_info
; let spec_bnds = [Id -> Expr Id -> OutBind
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]
bind_usage = (ScUsage
body_usg ScUsage -> [Id] -> ScUsage
`delCallsFor` [Id
bndr'])
ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
spec_usg
; return (bind_usage, spec_bnds, body', mconcat [warnings_bnd, warnings_body, rhs_ws])
}
| Bool
otherwise
= do { (rhs_usage, rhs', ws_rhs) <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr ScEnv
env Expr Id
rhs
; let body_env = ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv ScEnv
env Id
bndr (ValueEnv -> Expr Id -> Maybe Value
isValue (ScEnv -> ValueEnv
sc_vals ScEnv
env) Expr Id
rhs')
; (body_usage, body', body_warnings) <- do_body body_env
; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body', body_warnings ++ ws_rhs) }
scBind TopLevelFlag
top_lvl ScEnv
env (Rec [(Id, Expr Id)]
prs) ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning])
do_body
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
, Just Int
threshold <- SpecConstrOpts -> Maybe Int
sc_size (ScEnv -> SpecConstrOpts
sc_opts ScEnv
env)
, Bool -> Bool
not Bool
force_spec
, Bool -> Bool
not ((Expr Id -> Bool) -> [Expr Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (UnfoldingOpts -> Int -> Expr Id -> Bool
couldBeSmallEnoughToInline (SpecConstrOpts -> UnfoldingOpts
sc_uf_opts (ScEnv -> SpecConstrOpts
sc_opts ScEnv
env)) Int
threshold) [Expr Id]
rhss)
=
do { (body_usg, body', warnings_body) <- ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning])
do_body ScEnv
rhs_env2
; (rhs_usgs, rhss', rhs_ws) <- mapAndUnzip3M (scExpr env) rhss
; let all_usg = ([ScUsage] -> ScUsage
combineUsages [ScUsage]
rhs_usgs ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
body_usg)
ScUsage -> [Id] -> ScUsage
`delCallsFor` [Id]
bndrs'
bind' = [(Id, Expr Id)] -> OutBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Id]
bndrs' [Id] -> [Expr Id] -> [(Id, Expr Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr Id]
rhss')
; return (all_usg, [bind'], body', warnings_body ++ concat rhs_ws) }
| Bool
otherwise
= do { (rhs_infos, rhs_wss) <- ((Id, Expr Id) -> UniqSM (RhsInfo, [SpecFailWarning]))
-> [(Id, Expr Id)] -> UniqSM ([RhsInfo], [[SpecFailWarning]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (ScEnv -> (Id, Expr Id) -> UniqSM (RhsInfo, [SpecFailWarning])
scRecRhs ScEnv
rhs_env2) ([Id]
bndrs' [Id] -> [Expr Id] -> [(Id, Expr Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr Id]
rhss)
; let rhs_ws = [[SpecFailWarning]] -> [SpecFailWarning]
forall a. Monoid a => [a] -> a
mconcat [[SpecFailWarning]]
rhs_wss
; (body_usg, body', warnings_body) <- do_body rhs_env2
; (spec_usg, specs, spec_ws) <- specRec (scForce rhs_env2 force_spec)
(scu_calls body_usg) rhs_infos
; let all_usg = (ScUsage
spec_usg ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
body_usg)
ScUsage -> [Id] -> ScUsage
`delCallsFor` [Id]
bndrs'
bind' = [(Id, Expr Id)] -> OutBind
forall b. [(b, Expr b)] -> Bind b
Rec ([[(Id, Expr Id)]] -> [(Id, Expr Id)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String
-> (RhsInfo -> SpecInfo -> [(Id, Expr Id)])
-> [RhsInfo]
-> [SpecInfo]
-> [[(Id, Expr Id)]]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"scExpr'" RhsInfo -> SpecInfo -> [(Id, Expr Id)]
ruleInfoBinds [RhsInfo]
rhs_infos [SpecInfo]
specs))
; return (all_usg, [bind'], body', mconcat [warnings_body,rhs_ws,spec_ws]) }
where
([Id]
bndrs,[Expr Id]
rhss) = [(Id, Expr Id)] -> ([Id], [Expr Id])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, Expr Id)]
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
(ScEnv
rhs_env1,[Id]
bndrs') | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl = (ScEnv
env, [Id]
bndrs)
| Bool
otherwise = 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
withWarnings :: SpecFailWarnings -> (ScUsage, CoreExpr, SpecFailWarnings) -> (ScUsage, CoreExpr, SpecFailWarnings)
withWarnings :: [SpecFailWarning]
-> (ScUsage, Expr Id, [SpecFailWarning])
-> (ScUsage, Expr Id, [SpecFailWarning])
withWarnings [SpecFailWarning]
ws (ScUsage
use,Expr Id
expr,[SpecFailWarning]
ws2) = (ScUsage
use,Expr Id
expr,[SpecFailWarning]
ws [SpecFailWarning] -> [SpecFailWarning] -> [SpecFailWarning]
forall a. [a] -> [a] -> [a]
++ [SpecFailWarning]
ws2)
scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings)
scExpr :: ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr ScEnv
env Expr Id
e = ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr' ScEnv
env Expr Id
e
scExpr' :: ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr' ScEnv
env (Var Id
v) = case ScEnv -> Id -> Expr Id
scSubstId ScEnv
env Id
v of
Var Id
v' -> (ScUsage, Expr Id, [SpecFailWarning])
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv -> Id -> [Expr Id] -> ScUsage
mkVarUsage ScEnv
env Id
v' [], Id -> Expr Id
forall b. Id -> Expr b
Var Id
v', [])
Expr Id
e' -> ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr (ScEnv -> ScEnv
zapScSubst ScEnv
env) Expr Id
e'
scExpr' ScEnv
env (Type InType
t) =
let !(MkSolo InType
ty') = ScEnv -> InType -> Solo InType
scSubstTy ScEnv
env InType
t
in (ScUsage, Expr Id, [SpecFailWarning])
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, InType -> Expr Id
forall b. InType -> Expr b
Type InType
ty', [])
scExpr' ScEnv
env (Coercion Coercion
c) = (ScUsage, Expr Id, [SpecFailWarning])
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, Coercion -> Expr Id
forall b. Coercion -> Expr b
Coercion (ScEnv -> Coercion -> Coercion
scSubstCo ScEnv
env Coercion
c), [])
scExpr' ScEnv
_ e :: Expr Id
e@(Lit {}) = (ScUsage, Expr Id, [SpecFailWarning])
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, Expr Id
e, [])
scExpr' ScEnv
env (Tick CoreTickish
t Expr Id
e) = do (usg, e', ws) <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr ScEnv
env Expr Id
e
return (usg, Tick (scTickish env t) e', ws)
scExpr' ScEnv
env (Cast Expr Id
e Coercion
co) = do (usg, e', ws) <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr ScEnv
env Expr Id
e
return (usg, mkCast e' (scSubstCo env co), ws)
scExpr' ScEnv
env e :: Expr Id
e@(App Expr Id
_ Expr Id
_) = ScEnv
-> (Expr Id, [Expr Id])
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scApp ScEnv
env (Expr Id -> (Expr Id, [Expr Id])
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
(usg, e', ws) <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr ScEnv
env' Expr Id
e
return (usg, Lam b' e', ws)
scExpr' ScEnv
env (Let OutBind
bind Expr Id
body)
= do { (final_usage, binds', body', ws) <- TopLevelFlag
-> ScEnv
-> OutBind
-> (ScEnv -> UniqSM (ScUsage, Expr Id, [SpecFailWarning]))
-> UniqSM (ScUsage, [OutBind], Expr Id, [SpecFailWarning])
forall a.
TopLevelFlag
-> ScEnv
-> OutBind
-> (ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning]))
-> UniqSM (ScUsage, [OutBind], a, [SpecFailWarning])
scBind TopLevelFlag
NotTopLevel ScEnv
env OutBind
bind ((ScEnv -> UniqSM (ScUsage, Expr Id, [SpecFailWarning]))
-> UniqSM (ScUsage, [OutBind], Expr Id, [SpecFailWarning]))
-> (ScEnv -> UniqSM (ScUsage, Expr Id, [SpecFailWarning]))
-> UniqSM (ScUsage, [OutBind], Expr Id, [SpecFailWarning])
forall a b. (a -> b) -> a -> b
$
(\ScEnv
env -> ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr ScEnv
env Expr Id
body)
; return (final_usage, mkLets binds' body', ws) }
scExpr' ScEnv
env (Case Expr Id
scrut Id
b InType
ty [Alt Id]
alts)
= do { (scrut_usg, scrut', ws) <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr ScEnv
env Expr Id
scrut
; case isValue (sc_vals env) scrut' of
Just (ConVal Bool
args_are_work_free AltCon
con [Expr Id]
args)
| Bool
args_are_work_free -> AltCon
-> [Expr Id]
-> Expr Id
-> [SpecFailWarning]
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
sc_con_app AltCon
con [Expr Id]
args Expr Id
scrut' [SpecFailWarning]
ws
Maybe Value
_other -> ScUsage
-> Expr Id
-> [SpecFailWarning]
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
sc_vanilla ScUsage
scrut_usg Expr Id
scrut' [SpecFailWarning]
ws
}
where
sc_con_app :: AltCon
-> [Expr Id]
-> Expr Id
-> [SpecFailWarning]
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
sc_con_app AltCon
con [Expr Id]
args Expr Id
scrut' [SpecFailWarning]
ws
= do { let Alt AltCon
_ [Id]
bs Expr Id
rhs = AltCon -> [Alt Id] -> Maybe (Alt Id)
forall b. AltCon -> [Alt b] -> Maybe (Alt b)
findAlt AltCon
con [Alt Id]
alts
Maybe (Alt Id) -> Alt Id -> Alt Id
forall a. Maybe a -> a -> a
`orElse` AltCon -> [Id] -> Expr Id -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] (InType -> String -> Expr Id
mkImpossibleExpr InType
ty String
"SpecConstr")
alt_env' :: ScEnv
alt_env' = ScEnv -> [(Id, Expr Id)] -> ScEnv
extendScSubstList ScEnv
env ((Id
b,Expr Id
scrut') (Id, Expr Id) -> [(Id, Expr Id)] -> [(Id, Expr Id)]
forall a. a -> [a] -> [a]
: [Id]
bs [Id] -> [Expr Id] -> [(Id, Expr Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` AltCon -> [Expr Id] -> [Expr Id]
trimConArgs AltCon
con [Expr Id]
args)
; (use',expr',ws_new) <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr ScEnv
alt_env' Expr Id
rhs
; return (use',expr',ws ++ ws_new) }
sc_vanilla :: ScUsage
-> Expr Id
-> [SpecFailWarning]
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
sc_vanilla ScUsage
scrut_usg Expr Id
scrut' [SpecFailWarning]
ws
= do { let (ScEnv
alt_env,Id
b') = HowBound -> ScEnv -> Id -> (ScEnv, Id)
extendBndrWith HowBound
RecArg ScEnv
env Id
b
; (alt_usgs, alt_occs, alts', ws_alts) <- (Alt Id -> UniqSM (ScUsage, ArgOcc, Alt Id, [SpecFailWarning]))
-> [Alt Id]
-> UniqSM ([ScUsage], [ArgOcc], [Alt Id], [[SpecFailWarning]])
forall (m :: * -> *) a b c d e.
Monad m =>
(a -> m (b, c, d, e)) -> [a] -> m ([b], [c], [d], [e])
mapAndUnzip4M (ScEnv
-> Expr Id
-> Id
-> Alt Id
-> UniqSM (ScUsage, ArgOcc, Alt Id, [SpecFailWarning])
sc_alt ScEnv
alt_env Expr Id
scrut' Id
b') [Alt Id]
alts
; let scrut_occ = (ArgOcc -> ArgOcc -> ArgOcc) -> ArgOcc -> [ArgOcc] -> ArgOcc
forall a b. (a -> b -> b) -> b -> [a] -> b
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' = ScEnv -> ScUsage -> Expr Id -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
scrut_usg Expr Id
scrut' ArgOcc
scrut_occ
; let !(MkSolo ty') = scSubstTy env ty
; return (foldr combineUsage scrut_usg' alt_usgs,
Case scrut' b' ty' alts', ws ++ concat ws_alts) }
single_alt :: Bool
single_alt = [Alt Id] -> Bool
forall a. [a] -> Bool
isSingleton [Alt Id]
alts
sc_alt :: ScEnv
-> Expr Id
-> Id
-> Alt Id
-> UniqSM (ScUsage, ArgOcc, Alt Id, [SpecFailWarning])
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
; (usg, rhs', ws) <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr ScEnv
env2 Expr Id
rhs
; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)
scrut_occ = case AltCon
con of
DataAlt DataCon
dc
| Bool -> Bool
not (Bool
single_alt Bool -> Bool -> Bool
&& (ArgOcc -> Bool) -> [ArgOcc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ArgOcc -> Bool
deadArgOcc [ArgOcc]
arg_occs)
-> DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc (DataCon -> [ArgOcc] -> DataConEnv [ArgOcc]
forall key elt. Uniquable key => key -> elt -> UniqFM key elt
unitUFM DataCon
dc [ArgOcc]
arg_occs)
AltCon
_ -> ArgOcc
UnkOcc
; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs', ws) }
scTickish :: ScEnv -> CoreTickish -> CoreTickish
scTickish :: ScEnv -> CoreTickish -> CoreTickish
scTickish SCE {sc_subst :: ScEnv -> Subst
sc_subst = Subst
subst} = Subst -> CoreTickish -> CoreTickish
substTickish Subst
subst
scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings)
scApp :: ScEnv
-> (Expr Id, [Expr Id])
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scApp ScEnv
env (Var Id
fn, [Expr Id]
args)
= Bool
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([Expr Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr Id]
args)) (UniqSM (ScUsage, Expr Id, [SpecFailWarning])
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning]))
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
forall a b. (a -> b) -> a -> b
$
do { args_w_usgs <- (Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning]))
-> [Expr Id] -> UniqSM [(ScUsage, Expr Id, [SpecFailWarning])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr ScEnv
env) [Expr Id]
args
; let (arg_usgs, args', arg_ws) = unzip3 args_w_usgs
arg_usg = [ScUsage] -> ScUsage
combineUsages [ScUsage]
arg_usgs
arg_w = [[SpecFailWarning]] -> [SpecFailWarning]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[SpecFailWarning]]
arg_ws
; case scSubstId env fn of
fn' :: Expr Id
fn'@(Lam {}) -> [SpecFailWarning]
-> (ScUsage, Expr Id, [SpecFailWarning])
-> (ScUsage, Expr Id, [SpecFailWarning])
withWarnings [SpecFailWarning]
arg_w ((ScUsage, Expr Id, [SpecFailWarning])
-> (ScUsage, Expr Id, [SpecFailWarning]))
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr (ScEnv -> ScEnv
zapScSubst ScEnv
env) (Expr Id -> [Expr Id] -> Expr Id
doBeta Expr Id
fn' [Expr Id]
args')
Var Id
fn' -> (ScUsage, Expr Id, [SpecFailWarning])
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
forall a. a -> UniqSM a
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',
Expr Id -> [Expr Id] -> Expr Id
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr Id
forall b. Id -> Expr b
Var Id
fn') [Expr Id]
args', [SpecFailWarning]
arg_w )
where
arg_usg' :: ScUsage
arg_usg' | Just Class
cls <- Id -> Maybe Class
isClassOpId_maybe Id
fn'
, Expr Id
dict_arg : [Expr Id]
_ <- [Id] -> [Expr Id] -> [Expr Id]
forall b a. [b] -> [a] -> [a]
dropList (Class -> [Id]
classTyVars Class
cls) [Expr Id]
args'
= ScEnv -> ScUsage -> Expr Id -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
arg_usg Expr Id
dict_arg ArgOcc
evalScrutOcc
| Bool
otherwise
= ScUsage
arg_usg
Expr Id
other_fn' -> (ScUsage, Expr Id, [SpecFailWarning])
-> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
arg_usg, Expr Id -> [Expr Id] -> Expr Id
forall b. Expr b -> [Expr b] -> Expr b
mkApps Expr Id
other_fn' [Expr Id]
args', [SpecFailWarning]
arg_w) }
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) = OutBind -> Expr Id -> Expr Id
forall b. Bind b -> Expr b -> Expr b
Let (Id -> Expr Id -> OutBind
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 = Expr Id -> [Expr Id] -> Expr Id
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 { (fn_usg, fn', fn_ws) <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr ScEnv
env Expr Id
other_fn
; (arg_usgs, args', arg_ws) <- mapAndUnzip3M (scExpr env) args
; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args', combineSpecWarning fn_ws (concat arg_ws)) }
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 = Id -> [Call] -> CallEnv
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 = IdEnv ArgOcc
forall a. VarEnv a
emptyVarEnv }
Just HowBound
RecArg -> 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 | [Expr Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr Id]
args = ArgOcc
UnkOcc
| Bool
otherwise = ArgOcc
evalScrutOcc
scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (RhsInfo, SpecFailWarnings)
scRecRhs :: ScEnv -> (Id, Expr Id) -> UniqSM (RhsInfo, [SpecFailWarning])
scRecRhs ScEnv
env (Id
bndr,Expr Id
rhs)
= do { let ([Id]
arg_bndrs,Expr Id
body) = Expr Id -> ([Id], Expr Id)
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
; (body_usg, body', body_ws) <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id, [SpecFailWarning])
scExpr ScEnv
body_env Expr Id
body
; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
; return (RI { ri_rhs_usg = rhs_usg
, ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body'
, ri_lam_bndrs = arg_bndrs, ri_lam_body = body
, ri_arg_occs = arg_occs }, body_ws) }
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] [(Id, Expr Id)] -> [(Id, Expr Id)] -> [(Id, Expr Id)]
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 }
initSpecInfo :: RhsInfo -> SpecInfo
initSpecInfo :: RhsInfo -> SpecInfo
initSpecInfo (RI { ri_rhs_usg :: RhsInfo -> ScUsage
ri_rhs_usg = ScUsage
rhs_usg })
= SI { si_specs :: [OneSpec]
si_specs = [], si_n_specs :: Int
si_n_specs = Int
0, si_mb_unspec :: Maybe ScUsage
si_mb_unspec = ScUsage -> Maybe ScUsage
forall a. a -> Maybe a
Just ScUsage
rhs_usg }
specNonRec :: ScEnv
-> CallEnv
-> RhsInfo
-> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])
specNonRec :: ScEnv
-> CallEnv
-> RhsInfo
-> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])
specNonRec ScEnv
env CallEnv
body_calls RhsInfo
rhs_info
= ScEnv
-> CallEnv
-> RhsInfo
-> SpecInfo
-> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])
specialise ScEnv
env CallEnv
body_calls RhsInfo
rhs_info (RhsInfo -> SpecInfo
initSpecInfo RhsInfo
rhs_info)
specRec :: ScEnv
-> CallEnv
-> [RhsInfo]
-> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings)
specRec :: ScEnv
-> CallEnv
-> [RhsInfo]
-> UniqSM (ScUsage, [SpecInfo], [SpecFailWarning])
specRec ScEnv
env CallEnv
body_calls [RhsInfo]
rhs_infos
= Int
-> CallEnv
-> ScUsage
-> [SpecInfo]
-> [SpecFailWarning]
-> UniqSM (ScUsage, [SpecInfo], [SpecFailWarning])
go Int
1 CallEnv
body_calls ScUsage
nullUsage ((RhsInfo -> SpecInfo) -> [RhsInfo] -> [SpecInfo]
forall a b. (a -> b) -> [a] -> [b]
map RhsInfo -> SpecInfo
initSpecInfo [RhsInfo]
rhs_infos) []
where
opts :: SpecConstrOpts
opts = ScEnv -> SpecConstrOpts
sc_opts ScEnv
env
go, go_again :: Int
-> CallEnv
-> ScUsage
-> [SpecInfo]
-> SpecFailWarnings
-> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings)
go :: Int
-> CallEnv
-> ScUsage
-> [SpecInfo]
-> [SpecFailWarning]
-> UniqSM (ScUsage, [SpecInfo], [SpecFailWarning])
go Int
n_iter CallEnv
seed_calls ScUsage
usg_so_far [SpecInfo]
spec_infos [SpecFailWarning]
ws_so_far
=
do { specs_w_usg <- (RhsInfo
-> SpecInfo -> UniqSM (ScUsage, SpecInfo, [SpecFailWarning]))
-> [RhsInfo]
-> [SpecInfo]
-> UniqSM [(ScUsage, SpecInfo, [SpecFailWarning])]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (ScEnv
-> CallEnv
-> RhsInfo
-> SpecInfo
-> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])
specialise ScEnv
env CallEnv
seed_calls) [RhsInfo]
rhs_infos [SpecInfo]
spec_infos
; let (extra_usg_s, all_spec_infos, extra_ws ) = unzip3 specs_w_usg
extra_usg = [ScUsage] -> ScUsage
combineUsages [ScUsage]
extra_usg_s
all_usg = ScUsage
usg_so_far ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
extra_usg
new_calls = ScUsage -> CallEnv
scu_calls ScUsage
extra_usg
; go_again n_iter new_calls all_usg all_spec_infos (ws_so_far ++ concat extra_ws) }
go_again :: Int
-> CallEnv
-> ScUsage
-> [SpecInfo]
-> [SpecFailWarning]
-> UniqSM (ScUsage, [SpecInfo], [SpecFailWarning])
go_again Int
n_iter CallEnv
seed_calls ScUsage
usg_so_far [SpecInfo]
spec_infos [SpecFailWarning]
ws_so_far
| CallEnv -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv CallEnv
seed_calls
= (ScUsage, [SpecInfo], [SpecFailWarning])
-> UniqSM (ScUsage, [SpecInfo], [SpecFailWarning])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg_so_far, [SpecInfo]
spec_infos, [SpecFailWarning]
ws_so_far)
| Int
n_iter Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> SpecConstrOpts -> Int
sc_recursive SpecConstrOpts
opts
, ScEnv -> Bool
sc_force ScEnv
env Bool -> Bool -> Bool
|| Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing (SpecConstrOpts -> Maybe Int
sc_count SpecConstrOpts
opts)
, (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
=
let rhs_usgs :: ScUsage
rhs_usgs = [ScUsage] -> ScUsage
combineUsages ((SpecInfo -> Maybe ScUsage) -> [SpecInfo] -> [ScUsage]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SpecInfo -> Maybe ScUsage
si_mb_unspec [SpecInfo]
spec_infos)
in (ScUsage, [SpecInfo], [SpecFailWarning])
-> UniqSM (ScUsage, [SpecInfo], [SpecFailWarning])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg_so_far ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
rhs_usgs, [SpecInfo]
spec_infos, [SpecFailWarning]
ws_so_far)
| Bool
otherwise
= Int
-> CallEnv
-> ScUsage
-> [SpecInfo]
-> [SpecFailWarning]
-> UniqSM (ScUsage, [SpecInfo], [SpecFailWarning])
go (Int
n_iter Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) CallEnv
seed_calls ScUsage
usg_so_far [SpecInfo]
spec_infos [SpecFailWarning]
ws_so_far
the_limit :: Int
the_limit = case SpecConstrOpts -> Maybe Int
sc_count SpecConstrOpts
opts of
Maybe Int
Nothing -> Int
10
Just Int
max -> Int
max
specialise
:: ScEnv
-> CallEnv
-> RhsInfo
-> SpecInfo
-> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])
specialise :: ScEnv
-> CallEnv
-> RhsInfo
-> SpecInfo
-> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])
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
=
(ScUsage, SpecInfo, [SpecFailWarning])
-> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, SpecInfo
spec_info, [])
| Bool -> Bool
not (Activation -> Bool
isNeverActive (Id -> Activation
idInlineActivation Id
fn))
, Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
arg_bndrs)
, Just [Call]
all_calls <- CallEnv -> Id -> Maybe [Call]
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv CallEnv
bind_calls Id
fn
=
do { (boring_call, pats_discarded, new_pats, warnings)
<- ScEnv
-> Id
-> SpecInfo
-> [ArgOcc]
-> [Call]
-> UniqSM (Bool, Bool, [CallPat], [SpecFailWarning])
callsToNewPats ScEnv
env Id
fn SpecInfo
spec_info [ArgOcc]
arg_occs [Call]
all_calls
; let n_pats = [CallPat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CallPat]
new_pats
; let spec_env = ScEnv -> Int -> ScEnv
decreaseSpecCount ScEnv
env Int
n_pats
; (spec_usgs, new_specs, new_wss) <- mapAndUnzip3M (spec_one spec_env fn arg_bndrs body)
(new_pats `zip` [spec_count..])
; let spec_usg = [ScUsage] -> ScUsage
combineUsages [ScUsage]
spec_usgs
unspec_rhs_needed = Bool
pats_discarded Bool -> Bool -> Bool
|| Bool
boring_call Bool -> Bool -> Bool
|| Id -> Bool
isExportedId Id
fn
(new_usg, mb_unspec') = case mb_unspec of
Just ScUsage
rhs_usg | Bool
unspec_rhs_needed
-> (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)
; return (new_usg, SI { si_specs = new_specs ++ specs
, si_n_specs = spec_count + n_pats
, si_mb_unspec = mb_unspec' }
,warnings ++ concat new_wss) }
| Bool
otherwise
=
case Maybe ScUsage
mb_unspec of
Just ScUsage
rhs_usg -> (ScUsage, SpecInfo, [SpecFailWarning])
-> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
rhs_usg, SpecInfo
spec_info { si_mb_unspec = Nothing }, [])
Maybe ScUsage
Nothing -> (ScUsage, SpecInfo, [SpecFailWarning])
-> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])
forall a. a -> UniqSM a
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, SpecFailWarnings)
spec_one :: ScEnv
-> Id
-> [Id]
-> Expr Id
-> (CallPat, Int)
-> UniqSM (ScUsage, OneSpec, [SpecFailWarning])
spec_one ScEnv
env Id
fn [Id]
arg_bndrs Expr Id
body (CallPat
call_pat, Int
rule_number)
| CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
qvars, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
pats, cp_strict_args :: CallPat -> [Id]
cp_strict_args = [Id]
cbv_args } <- CallPat
call_pat
= do {
; spec_uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let env1 = ScEnv -> [(Id, Expr Id)] -> ScEnv
extendScSubstList (ScEnv -> [Id] -> ScEnv
extendScInScope ScEnv
env [Id]
qvars)
([Id]
arg_bndrs [Id] -> [Expr Id] -> [(Id, Expr Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr Id]
pats)
(body_env, extra_bndrs) = extendBndrs env1 (dropList pats arg_bndrs)
fn_name = Id -> Name
idName Id
fn
fn_loc = Name -> SrcSpan
nameSrcSpan Name
fn_name
fn_occ = Name -> OccName
nameOccName Name
fn_name
spec_occ = OccName -> OccName
mkSpecOcc OccName
fn_occ
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 = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
spec_uniq OccName
spec_occ SrcSpan
fn_loc
; (spec_usg, spec_body, body_warnings) <- scExpr body_env body
; (qvars', pats') <- generaliseDictPats qvars pats
; let spec_body_ty = HasDebugCallStack => Expr Id -> InType
Expr Id -> InType
exprType Expr Id
spec_body
(spec_lam_args, spec_call_args, spec_sig)
= calcSpecInfo fn arg_bndrs call_pat extra_bndrs
spec_arity = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
spec_lam_args
spec_join_arity | Id -> Bool
isJoinId Id
fn = Int -> JoinPointHood
JoinPoint ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
spec_call_args)
| Bool
otherwise = JoinPointHood
NotJoinPoint
spec_id = Id -> Id
asWorkerLikeId (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => Name -> InType -> InType -> Id
Name -> InType -> InType -> Id
mkLocalId Name
spec_name InType
ManyTy
([Id] -> InType -> InType
mkLamTypes [Id]
spec_lam_args InType
spec_body_ty)
Id -> DmdSig -> Id
`setIdDmdSig` DmdSig
spec_sig
Id -> CprSig -> Id
`setIdCprSig` CprSig
topCprSig
Id -> Int -> Id
`setIdArity` Int
spec_arity
Id -> JoinPointHood -> Id
`asJoinId_maybe` JoinPointHood
spec_join_arity
spec_rhs = [Id] -> Expr Id -> Expr Id
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
spec_lam_args ([Id] -> InType -> Expr Id -> Expr Id
mkSeqs [Id]
cbv_args InType
spec_body_ty Expr Id
spec_body)
rule_rhs = Expr Id -> [Id] -> Expr Id
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> Expr Id
forall b. Id -> Expr b
Var Id
spec_id) [Id]
spec_call_args
inline_act = Id -> Activation
idInlineActivation Id
fn
this_mod = SpecConstrOpts -> Module
sc_module (SpecConstrOpts -> Module) -> SpecConstrOpts -> Module
forall a b. (a -> b) -> a -> b
$ ScEnv -> SpecConstrOpts
sc_opts ScEnv
env
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
; return (spec_usg, OS { os_pat = call_pat, os_rule = rule
, os_id = spec_id
, os_rhs = spec_rhs }, body_warnings) }
generaliseDictPats :: [Var] -> [CoreExpr]
-> UniqSM ([Var], [CoreExpr])
generaliseDictPats :: [Id] -> [Expr Id] -> UniqSM ([Id], [Expr Id])
generaliseDictPats [Id]
qvars [Expr Id]
pats
= do { (extra_qvars, pats') <- ([Id] -> Expr Id -> UniqSM ([Id], Expr Id))
-> [Id] -> [Expr Id] -> UniqSM ([Id], [Expr Id])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM [Id] -> Expr Id -> UniqSM ([Id], Expr Id)
go [] [Expr Id]
pats
; case extra_qvars of
[] -> ([Id], [Expr Id]) -> UniqSM ([Id], [Expr Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
qvars, [Expr Id]
pats)
[Id]
_ -> ([Id], [Expr Id]) -> UniqSM ([Id], [Expr Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
qvars [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
extra_qvars, [Expr Id]
pats') }
where
qvar_set :: VarSet
qvar_set = [Id] -> VarSet
mkVarSet [Id]
qvars
go :: [Id] -> CoreExpr -> UniqSM ([Id], CoreExpr)
go :: [Id] -> Expr Id -> UniqSM ([Id], Expr Id)
go [Id]
extra_qvs Expr Id
pat
| Bool -> Bool
not (Expr Id -> Bool
forall b. Expr b -> Bool
isTyCoArg Expr Id
pat)
, let pat_ty :: InType
pat_ty = HasDebugCallStack => Expr Id -> InType
Expr Id -> InType
exprType Expr Id
pat
, InType -> Bool
typeDeterminesValue InType
pat_ty
, Expr Id -> VarSet
exprFreeVars Expr Id
pat VarSet -> VarSet -> Bool
`disjointVarSet` VarSet
qvar_set
= do { id <- FastString -> InType -> InType -> UniqSM Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> InType -> InType -> m Id
mkSysLocalOrCoVarM (String -> FastString
fsLit String
"dict") InType
ManyTy InType
pat_ty
; return (id:extra_qvs, Var id) }
| Bool
otherwise
= ([Id], Expr Id) -> UniqSM ([Id], Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
extra_qvs, Expr Id
pat)
mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr
mkSeqs :: [Id] -> InType -> Expr Id -> Expr Id
mkSeqs [Id]
seqees InType
res_ty Expr Id
rhs =
(Id -> Expr Id -> Expr Id) -> Expr Id -> [Id] -> Expr Id
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Id -> Expr Id -> Expr Id
addEval Expr Id
rhs [Id]
seqees
where
addEval :: Var -> CoreExpr -> CoreExpr
addEval :: Id -> Expr Id -> Expr Id
addEval Id
arg_id Expr Id
rhs
| Id -> Bool
shouldStrictifyIdForCbv Id
arg_id
= Expr Id -> Id -> InType -> [Alt Id] -> Expr Id
forall b. Expr b -> b -> InType -> [Alt b] -> Expr b
Case (Id -> Expr Id
forall b. Id -> Expr b
Var Id
arg_id)
(Id -> Id
localiseId Id
arg_id)
InType
res_ty
([AltCon -> [Id] -> Expr Id -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] Expr Id
rhs])
| Bool
otherwise
= Expr Id
rhs
calcSpecInfo :: Id
-> [InVar]
-> CallPat
-> [Var]
-> ( [Var]
, [Var]
, DmdSig )
calcSpecInfo :: Id -> [Id] -> CallPat -> [Id] -> ([Id], [Id], DmdSig)
calcSpecInfo Id
fn [Id]
arg_bndrs (CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
qvars, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
pats }) [Id]
extra_bndrs
= ( [Id]
spec_lam_bndrs_w_dmds
, [Id]
spec_call_args
, DmdSig -> DmdSig
zapDmdEnvSig (DmdType -> DmdSig
DmdSig (DmdType
dt{dt_args = spec_fn_dmds})) )
where
DmdSig dt :: DmdType
dt@DmdType{dt_args :: DmdType -> [Demand]
dt_args=[Demand]
fn_dmds} = Id -> DmdSig
idDmdSig Id
fn
spec_fn_dmds :: [Demand]
spec_fn_dmds = [Id -> Demand
idDemandInfo Id
b | Id
b <- [Id]
spec_lam_bndrs_w_dmds, Id -> Bool
isId Id
b]
val_pats :: [Expr Id]
val_pats = (Expr Id -> Bool) -> [Expr Id] -> [Expr Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Expr Id -> Bool
forall b. Expr b -> Bool
isTypeArg [Expr Id]
pats
arg_dmd_env :: VarEnv Demand
arg_dmd_env = VarEnv Demand -> [Demand] -> [Expr Id] -> VarEnv Demand
go VarEnv Demand
forall a. VarEnv a
emptyVarEnv [Demand]
fn_dmds [Expr Id]
val_pats
qvar_dmds :: [Demand]
qvar_dmds = [ VarEnv Demand -> Id -> Maybe Demand
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Demand
arg_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 ]
extra_dmds :: [Demand]
extra_dmds = [Expr Id] -> [Demand] -> [Demand]
forall b a. [b] -> [a] -> [a]
dropList [Expr Id]
val_pats [Demand]
fn_dmds
qvars_w_dmds :: [Id]
qvars_w_dmds = [Id] -> [Demand] -> [Id]
set_dmds [Id]
qvars [Demand]
qvar_dmds
extras_w_dmds :: [Id]
extras_w_dmds = [Id] -> [Demand] -> [Id]
set_dmds [Id]
extra_bndrs [Demand]
extra_dmds
spec_lam_bndrs_w_dmds :: [Id]
spec_lam_bndrs_w_dmds = [Id]
final_qvars_w_dmds [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
extras_w_dmds
([Id]
final_qvars_w_dmds, [Id]
spec_call_args)
| Id -> [Id] -> [Id] -> Bool
needsVoidWorkerArg Id
fn [Id]
arg_bndrs ([Id]
qvars [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
extra_bndrs)
= ( [Id]
qvars_w_dmds [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidArgId], [Id]
qvars [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidPrimId] )
| Bool
otherwise
= ( [Id]
qvars_w_dmds, [Id]
qvars )
set_dmds :: [Var] -> [Demand] -> [Var]
set_dmds :: [Id] -> [Demand] -> [Id]
set_dmds [] [Demand]
_ = []
set_dmds [Id]
vs [] = [Id]
vs
set_dmds (Id
v:[Id]
vs) ds :: [Demand]
ds@(Demand
d:[Demand]
ds') | Id -> Bool
isTyVar Id
v = Id
v Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id] -> [Demand] -> [Id]
set_dmds [Id]
vs [Demand]
ds
| Bool
otherwise = Id -> Demand -> Id
setIdDemandInfo Id
v Demand
d Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id] -> [Demand] -> [Id]
set_dmds [Id]
vs [Demand]
ds'
go :: VarEnv Demand -> [Demand] -> [CoreExpr] -> VarEnv Demand
go :: VarEnv Demand -> [Demand] -> [Expr Id] -> VarEnv Demand
go VarEnv Demand
env (Demand
d:[Demand]
ds) (Expr Id
pat : [Expr Id]
pats) = VarEnv Demand -> [Demand] -> [Expr Id] -> VarEnv Demand
go (VarEnv Demand -> Demand -> Expr Id -> VarEnv Demand
go_one VarEnv Demand
env Demand
d Expr Id
pat) [Demand]
ds [Expr Id]
pats
go VarEnv Demand
env [Demand]
_ [Expr Id]
_ = VarEnv Demand
env
go_one :: VarEnv Demand -> Demand -> CoreExpr -> VarEnv Demand
go_one :: VarEnv Demand -> Demand -> Expr Id -> 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
plusDmd VarEnv Demand
env Id
v Demand
d
go_one VarEnv Demand
env (Card
_n :* SubDemand
cd) Expr Id
e
| (Var Id
_, [Expr Id]
args) <- Expr Id -> (Expr Id, [Expr Id])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr Id
e
, Just (Boxity
_b, [Demand]
ds) <- Int -> SubDemand -> Maybe (Boxity, [Demand])
viewProd ([Expr Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr Id]
args) SubDemand
cd
= VarEnv Demand -> [Demand] -> [Expr Id] -> VarEnv Demand
go VarEnv Demand
env [Demand]
ds [Expr Id]
args
go_one VarEnv Demand
env Demand
_ Expr Id
_ = VarEnv Demand
env
data CallPat = CP { CallPat -> [Id]
cp_qvars :: [Var]
, CallPat -> [Expr Id]
cp_args :: [CoreExpr]
, CallPat -> [Id]
cp_strict_args :: [Var] }
instance Outputable CallPat where
ppr :: CallPat -> SDoc
ppr (CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
qvars, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
args, cp_strict_args :: CallPat -> [Id]
cp_strict_args = [Id]
strict })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CP" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cp_qvars =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
qvars SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cp_args =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Expr Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Expr Id]
args
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cp_strict_args = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
strict ])
newtype SpecFailWarning = SpecFailForcedArgCount { SpecFailWarning -> Name
spec_failed_fun_name :: Name }
type SpecFailWarnings = [SpecFailWarning]
instance Outputable SpecFailWarning where
ppr :: SpecFailWarning -> SDoc
ppr (SpecFailForcedArgCount Name
name) = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
pprDefinedAt Name
name
combineSpecWarning :: SpecFailWarnings -> SpecFailWarnings -> SpecFailWarnings
combineSpecWarning :: [SpecFailWarning] -> [SpecFailWarning] -> [SpecFailWarning]
combineSpecWarning = [SpecFailWarning] -> [SpecFailWarning] -> [SpecFailWarning]
forall a. [a] -> [a] -> [a]
(++)
data ArgCountResult = WorkerSmallEnough | WorkerTooLarge | WorkerTooLargeForced Name
callsToNewPats :: ScEnv -> Id
-> SpecInfo
-> [ArgOcc] -> [Call]
-> UniqSM ( Bool
, Bool
, [CallPat]
, [SpecFailWarning]
)
callsToNewPats :: ScEnv
-> Id
-> SpecInfo
-> [ArgOcc]
-> [Call]
-> UniqSM (Bool, Bool, [CallPat], [SpecFailWarning])
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 { mb_pats <- (Call -> UniqSM (Maybe CallPat))
-> [Call] -> UniqSM [Maybe CallPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
callToPat ScEnv
env [ArgOcc]
bndr_occs) [Call]
calls
; let have_boring_call = (Maybe CallPat -> Bool) -> [Maybe CallPat] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe CallPat -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe CallPat]
mb_pats
good_pats :: [CallPat]
good_pats = [Maybe CallPat] -> [CallPat]
forall a. [Maybe a] -> [a]
catMaybes [Maybe CallPat]
mb_pats
in_scope = Subst -> InScopeSet
getSubstInScope (ScEnv -> Subst
sc_subst ScEnv
env)
new_pats = (CallPat -> Bool) -> [CallPat] -> [CallPat]
forall a. (a -> Bool) -> [a] -> [a]
filterOut CallPat -> Bool
is_done [CallPat]
good_pats
is_done CallPat
p = (OneSpec -> Bool) -> [OneSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any OneSpec -> Bool
is_better [OneSpec]
done_specs
where
is_better :: OneSpec -> Bool
is_better OneSpec
done = InScopeSet -> CallPat -> CallPat -> Bool
betterPat InScopeSet
in_scope (OneSpec -> CallPat
os_pat OneSpec
done) CallPat
p
non_dups = InScopeSet -> [CallPat] -> [CallPat]
subsumePats InScopeSet
in_scope [CallPat]
new_pats
(small_pats, arg_count_warnings) = partitionByWorkerSize too_many_worker_args non_dups
too_many_worker_args (CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
vars, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
args })
| ScEnv -> Bool
sc_force ScEnv
env
= if (Int -> Int -> [Id] -> Bool
isWorkerSmallEnough (SpecConstrOpts -> Int
sc_max_forced_args (SpecConstrOpts -> Int) -> SpecConstrOpts -> Int
forall a b. (a -> b) -> a -> b
$ ScEnv -> SpecConstrOpts
sc_opts ScEnv
env) ([Expr Id] -> Int
forall b. [Arg b] -> Int
valArgCount [Expr Id]
args) [Id]
vars)
then ArgCountResult
WorkerSmallEnough
else Name -> ArgCountResult
WorkerTooLargeForced (Id -> Name
idName Id
fn)
| (Int -> Int -> [Id] -> Bool
isWorkerSmallEnough (SpecConstrOpts -> Int
sc_max_args (SpecConstrOpts -> Int) -> SpecConstrOpts -> Int
forall a b. (a -> b) -> a -> b
$ ScEnv -> SpecConstrOpts
sc_opts ScEnv
env) ([Expr Id] -> Int
forall b. [Arg b] -> Int
valArgCount [Expr Id]
args) [Id]
vars)
= ArgCountResult
WorkerSmallEnough
| Bool
otherwise = ArgCountResult
WorkerTooLarge
(pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats
; return (have_boring_call, pats_were_discarded, trimmed_pats, arg_count_warnings) }
where
partitionByWorkerSize :: (a -> ArgCountResult) -> [a] -> ([a], [SpecFailWarning])
partitionByWorkerSize a -> ArgCountResult
worker_size [a]
pats = [a] -> [a] -> [SpecFailWarning] -> ([a], [SpecFailWarning])
go [a]
pats [] []
where
go :: [a] -> [a] -> [SpecFailWarning] -> ([a], [SpecFailWarning])
go [] [a]
small [SpecFailWarning]
warnings = ([a]
small, [SpecFailWarning]
warnings)
go (a
p:[a]
ps) [a]
small [SpecFailWarning]
warnings =
case a -> ArgCountResult
worker_size a
p of
ArgCountResult
WorkerSmallEnough -> [a] -> [a] -> [SpecFailWarning] -> ([a], [SpecFailWarning])
go [a]
ps (a
pa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
small) [SpecFailWarning]
warnings
ArgCountResult
WorkerTooLarge -> [a] -> [a] -> [SpecFailWarning] -> ([a], [SpecFailWarning])
go [a]
ps [a]
small [SpecFailWarning]
warnings
WorkerTooLargeForced Name
name -> [a] -> [a] -> [SpecFailWarning] -> ([a], [SpecFailWarning])
go [a]
ps [a]
small (Name -> SpecFailWarning
SpecFailForcedArgCount Name
name SpecFailWarning -> [SpecFailWarning] -> [SpecFailWarning]
forall a. a -> [a] -> [a]
: [SpecFailWarning]
warnings)
trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])
trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [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
|| 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
=
(Bool
False, [CallPat]
pats)
| Bool
otherwise
= (Bool, [CallPat]) -> (Bool, [CallPat])
emit_trace ((Bool, [CallPat]) -> (Bool, [CallPat]))
-> (Bool, [CallPat]) -> (Bool, [CallPat])
forall a b. (a -> b) -> a -> b
$
(Bool
True, Int -> [CallPat] -> [CallPat]
forall a. Int -> [a] -> [a]
take Int
n_remaining [CallPat]
sorted_pats)
where
n_pats :: Int
n_pats = [CallPat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CallPat]
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 = SpecConstrOpts -> Maybe Int
sc_count (SpecConstrOpts -> Maybe Int) -> SpecConstrOpts -> Maybe Int
forall a b. (a -> b) -> a -> b
$ ScEnv -> SpecConstrOpts
sc_opts ScEnv
env
Just Int
max_specs = Maybe Int
mb_scc
sorted_pats :: [CallPat]
sorted_pats = ((CallPat, Int) -> CallPat) -> [(CallPat, Int)] -> [CallPat]
forall a b. (a -> b) -> [a] -> [b]
map (CallPat, Int) -> CallPat
forall a b. (a, b) -> a
fst ([(CallPat, Int)] -> [CallPat]) -> [(CallPat, Int)] -> [CallPat]
forall a b. (a -> b) -> a -> b
$
((CallPat, Int) -> (CallPat, Int) -> Ordering)
-> [(CallPat, Int)] -> [(CallPat, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((CallPat, Int) -> Int)
-> (CallPat, Int) -> (CallPat, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (CallPat, Int) -> Int
forall a b. (a, b) -> b
snd) ([(CallPat, Int)] -> [(CallPat, Int)])
-> [(CallPat, Int)] -> [(CallPat, Int)]
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 (CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
qs, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
ps })
= (Expr Id -> Int -> Int) -> Int -> [Expr Id] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
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) -> (Expr Id -> Int) -> Expr Id -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Id -> Int
n_cons) Int
0 [Expr Id]
ps
where
q_set :: VarSet
q_set = [Id] -> VarSet
mkVarSet [Id]
qs
n_cons :: Expr Id -> Int
n_cons (Var Id
v) | Id
v Id -> VarSet -> Bool
`elemVarSet` VarSet
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 Int -> Int -> Int
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 :: (Bool, [CallPat]) -> (Bool, [CallPat])
emit_trace (Bool, [CallPat])
result
| Bool
debugIsOn Bool -> Bool -> Bool
|| SpecConstrOpts -> Bool
sc_debug (ScEnv -> SpecConstrOpts
sc_opts ScEnv
env)
= String -> SDoc -> (Bool, [CallPat]) -> (Bool, [CallPat])
forall a. String -> SDoc -> a -> a
pprTrace String
"SpecConstr" SDoc
msg (Bool, [CallPat])
result
| Bool
otherwise
= (Bool, [CallPat])
result
msg :: SDoc
msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Function" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn)
, Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
Int -> SDoc -> SDoc
speakNOf Int
spec_count' (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"call pattern") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"but the limit is" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
max_specs) ]
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Use -fspec-constr-count=n to set the bound"
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"done_spec_count =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
done_spec_count
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Keeping " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n_remaining SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
", out of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n_pats
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Discarding:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [CallPat] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int -> [CallPat] -> [CallPat]
forall a. Int -> [a] -> [a]
drop Int
n_remaining [CallPat]
sorted_pats) ]
callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
callToPat ScEnv
env [ArgOcc]
bndr_occs call :: Call
call@(Call Id
fn [Expr Id]
args ValueEnv
con_env)
= do { let in_scope :: InScopeSet
in_scope = Subst -> InScopeSet
getSubstInScope (ScEnv -> Subst
sc_subst ScEnv
env)
; arg_triples <- (Expr Id
-> ArgOcc -> StrictnessMark -> UniqSM (Bool, Expr Id, [Id]))
-> [Expr Id]
-> [ArgOcc]
-> [StrictnessMark]
-> UniqSM [(Bool, Expr Id, [Id])]
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M (ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
con_env) [Expr Id]
args [ArgOcc]
bndr_occs ((Expr Id -> StrictnessMark) -> [Expr Id] -> [StrictnessMark]
forall a b. (a -> b) -> [a] -> [b]
map (StrictnessMark -> Expr Id -> StrictnessMark
forall a b. a -> b -> a
const StrictnessMark
NotMarkedStrict) [Expr Id]
args)
; let arg_triples' | Id -> Bool
isJoinId Id
fn = [(Bool, Expr Id, [Id])]
arg_triples
| Bool
otherwise = ((Bool, Expr Id, [Id]) -> Bool)
-> [(Bool, Expr Id, [Id])] -> [(Bool, Expr Id, [Id])]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Bool, Expr Id, [Id]) -> Bool
forall {b} {c}. (Bool, b, c) -> Bool
is_boring [(Bool, Expr Id, [Id])]
arg_triples
is_boring (Bool
interesting, b
_,c
_) = Bool -> Bool
not Bool
interesting
(interesting_s, pats, cbv_ids) = unzip3 arg_triples'
interesting = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
interesting_s
; let pat_fvs = [Expr Id] -> [Id]
exprsFreeVarsList [Expr Id]
pats
in_scope_vars = InScopeSet -> VarSet
getInScopeVars InScopeSet
in_scope
is_in_scope Id
v = Id
v Id -> VarSet -> Bool
`elemVarSet` VarSet
in_scope_vars
qvars = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Id -> Bool
is_in_scope [Id]
pat_fvs
(qktvs, qids) = partition isTyVar qvars
qvars' = [Id] -> [Id]
scopedSort [Id]
qktvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
sanitise [Id]
qids
sanitise Id
id = (InType -> InType) -> Id -> Id
updateIdTypeAndMult InType -> InType
expandTypeSynonyms Id
id
; let bad_covars = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isCoVar [Id]
qids
; warnPprTrace (not (null bad_covars))
"SpecConstr: bad covars"
(ppr bad_covars $$ ppr call) $
if interesting && null bad_covars
then do { let cp_res = CP { cp_qvars :: [Id]
cp_qvars = [Id]
qvars', cp_args :: [Expr Id]
cp_args = [Expr Id]
pats
, cp_strict_args :: [Id]
cp_strict_args = [[Id]] -> [Id]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Id]]
cbv_ids }
; return (Just cp_res) }
else return Nothing }
argToPat :: ScEnv
-> InScopeSet
-> ValueEnv
-> CoreArg
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, CoreArg, [Id])
argToPat :: ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ StrictnessMark
arg_str
= do
!res <- ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat1 ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ StrictnessMark
arg_str
return res
argToPat1 :: ScEnv
-> InScopeSet
-> ValueEnv
-> Expr CoreBndr
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr CoreBndr, [Id])
argToPat1 :: ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat1 ScEnv
_env InScopeSet
_in_scope ValueEnv
_val_env arg :: Expr Id
arg@(Type {}) ArgOcc
_arg_occ StrictnessMark
_arg_str
= (Bool, Expr Id, [Id]) -> UniqSM (Bool, Expr Id, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Expr Id
arg, [])
argToPat1 ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Tick CoreTickish
_ Expr Id
arg) ArgOcc
arg_occ StrictnessMark
arg_str
= ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ StrictnessMark
arg_str
argToPat1 ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Let OutBind
_ Expr Id
arg) ArgOcc
arg_occ StrictnessMark
arg_str
= ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ StrictnessMark
arg_str
argToPat1 ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Cast Expr Id
arg Coercion
co) ArgOcc
arg_occ StrictnessMark
arg_str
| Bool -> Bool
not (ScEnv -> InType -> Bool
ignoreType ScEnv
env InType
ty2)
= do { (interesting, arg', strict_args) <- ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ StrictnessMark
arg_str
; if not interesting then
wildCardPat ty2 arg_str
else
return (interesting, Cast arg' co, strict_args) }
where
ty2 :: InType
ty2 = HasDebugCallStack => Coercion -> InType
Coercion -> InType
coercionRKind Coercion
co
argToPat1 ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ StrictnessMark
_arg_str
| Just (ConVal Bool
_wf (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) = [Id] -> [Expr Id] -> ([Expr Id], [Expr Id])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList (DataCon -> [Id]
dataConUnivTyVars DataCon
dc) [Expr Id]
args
con_str, matched_str :: [StrictnessMark]
con_str :: [StrictnessMark]
con_str = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
dc
matched_str :: [StrictnessMark]
matched_str = [StrictnessMark] -> [Expr Id] -> [StrictnessMark]
match_vals [StrictnessMark]
con_str [Expr Id]
rest_args
; prs <- (Expr Id
-> ArgOcc -> StrictnessMark -> UniqSM (Bool, Expr Id, [Id]))
-> [Expr Id]
-> [ArgOcc]
-> [StrictnessMark]
-> UniqSM [(Bool, Expr Id, [Id])]
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M (ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env) [Expr Id]
rest_args [ArgOcc]
arg_occs [StrictnessMark]
matched_str
; let args' = ((Bool, Expr Id, [Id]) -> Expr Id)
-> [(Bool, Expr Id, [Id])] -> [Expr Id]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Expr Id, [Id]) -> Expr Id
forall a b c. (a, b, c) -> b
sndOf3 [(Bool, Expr Id, [Id])]
prs :: [CoreArg]
; assertPpr (length con_str == length (filter isRuntimeArg rest_args))
( ppr con_str $$ ppr rest_args $$
ppr (length con_str) $$ ppr (length rest_args)
) $ return ()
; return (True, mkConApp dc (ty_args ++ args'), concat (map thdOf3 prs)) }
where
mb_scrut :: DataCon -> Maybe [ArgOcc]
mb_scrut DataCon
dc = case ArgOcc
arg_occ of
ScrutOcc DataConEnv [ArgOcc]
bs | Just [ArgOcc]
occs <- DataConEnv [ArgOcc] -> DataCon -> Maybe [ArgOcc]
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM DataConEnv [ArgOcc]
bs DataCon
dc
-> [ArgOcc] -> Maybe [ArgOcc]
forall a. a -> Maybe a
Just ([ArgOcc]
occs)
ArgOcc
_other | ScEnv -> Bool
sc_force ScEnv
env Bool -> Bool -> Bool
|| SpecConstrOpts -> Bool
sc_keen (ScEnv -> SpecConstrOpts
sc_opts 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
match_vals :: [StrictnessMark] -> [Expr Id] -> [StrictnessMark]
match_vals [StrictnessMark]
bangs (Expr Id
arg:[Expr Id]
args)
| Expr Id -> Bool
forall b. Expr b -> Bool
isTypeArg Expr Id
arg
= StrictnessMark
NotMarkedStrict StrictnessMark -> [StrictnessMark] -> [StrictnessMark]
forall a. a -> [a] -> [a]
: [StrictnessMark] -> [Expr Id] -> [StrictnessMark]
match_vals [StrictnessMark]
bangs [Expr Id]
args
| (StrictnessMark
b:[StrictnessMark]
bs) <- [StrictnessMark]
bangs
= StrictnessMark
b StrictnessMark -> [StrictnessMark] -> [StrictnessMark]
forall a. a -> [a] -> [a]
: [StrictnessMark] -> [Expr Id] -> [StrictnessMark]
match_vals [StrictnessMark]
bs [Expr Id]
args
match_vals [] [] = []
match_vals [StrictnessMark]
as [Expr Id]
bs =
String -> SDoc -> [StrictnessMark]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"spec-constr:argToPat - Bangs don't match value arguments"
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Expr Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr Id
arg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"remaining args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [StrictnessMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StrictnessMark]
as SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"remaining bangs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Expr Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Expr Id]
bs)
argToPat1 ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Var Id
v) ArgOcc
arg_occ StrictnessMark
arg_str
| ScEnv -> Bool
sc_force ScEnv
env Bool -> Bool -> Bool
|| ArgOcc -> Bool
specialisableArgOcc ArgOcc
arg_occ
, Bool
is_value
, Bool -> Bool
not (ScEnv -> InType -> Bool
ignoreType ScEnv
env (Id -> InType
varType Id
v))
= (Bool, Expr Id, [Id]) -> UniqSM (Bool, Expr Id, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Id -> Expr Id
forall b. Id -> Expr b
Var Id
v, if StrictnessMark -> Bool
isMarkedStrict StrictnessMark
arg_str then [Id
v] else [Id]
forall a. Monoid a => a
mempty)
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 (IdUnfoldingFun
idUnfolding Id
v)
argToPat1 ScEnv
_env InScopeSet
_in_scope ValueEnv
_val_env Expr Id
arg ArgOcc
_arg_occ StrictnessMark
arg_str
= InType -> StrictnessMark -> UniqSM (Bool, Expr Id, [Id])
wildCardPat (HasDebugCallStack => Expr Id -> InType
Expr Id -> InType
exprType Expr Id
arg) StrictnessMark
arg_str
wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id])
wildCardPat :: InType -> StrictnessMark -> UniqSM (Bool, Expr Id, [Id])
wildCardPat InType
ty StrictnessMark
str
= do { id <- FastString -> InType -> InType -> UniqSM Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> InType -> InType -> m Id
mkSysLocalOrCoVarM (String -> FastString
fsLit String
"sc") InType
ManyTy InType
ty
; return (False, varToCoreExpr id, if isMarkedStrict str then [id] else []) }
isValue :: ValueEnv -> CoreExpr -> Maybe Value
isValue :: ValueEnv -> Expr Id -> 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 (Bool -> AltCon -> [Expr Id] -> Value
ConVal Bool
True (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)
, Unfolding -> Bool
isCheapUnfolding Unfolding
unf
, Just Expr Id
rhs <- Unfolding -> Maybe (Expr Id)
maybeUnfoldingTemplate Unfolding
unf
= ValueEnv -> Expr Id -> Maybe Value
isValue ValueEnv
env Expr Id
rhs
where
unf :: Unfolding
unf = IdUnfoldingFun
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
_ -> 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 CoreTickish
t Expr Id
e)
| Bool -> Bool
not (CoreTickish -> Bool
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]
_) <- (CoreTickish -> Bool)
-> Expr Id -> (Expr Id, [Expr Id], [CoreTickish])
forall b.
(CoreTickish -> Bool)
-> Expr b -> (Expr b, [Expr b], [CoreTickish])
collectArgsTicks (Bool -> Bool
not (Bool -> Bool) -> (CoreTickish -> Bool) -> CoreTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) Expr Id
expr
= case Id -> IdDetails
idDetails Id
fun of
DataConWorkId DataCon
con | [Expr Id]
args [Expr Id] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` DataCon -> Int
dataConRepArity DataCon
con
-> Value -> Maybe Value
forall a. a -> Maybe a
Just (Bool -> AltCon -> [Expr Id] -> Value
ConVal ((Expr Id -> Bool) -> [Expr Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Expr Id -> Bool
exprIsWorkFree [Expr Id]
args) (DataCon -> AltCon
DataAlt DataCon
con) [Expr Id]
args)
DFunId {} -> Value -> Maybe Value
forall a. a -> Maybe a
Just Value
LambdaVal
IdDetails
_other | [Expr Id] -> Int
forall b. [Arg b] -> Int
valArgCount [Expr Id]
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
IdDetails
_other -> Maybe Value
forall a. Maybe a
Nothing
isValue ValueEnv
_env Expr Id
_expr = Maybe Value
forall a. Maybe a
Nothing
betterPat :: InScopeSet -> CallPat -> CallPat -> Bool
betterPat :: InScopeSet -> CallPat -> CallPat -> Bool
betterPat InScopeSet
is (CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
vs1, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
as1 })
(CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
vs2, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
as2 })
| [Expr Id] -> [Expr Id] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Expr Id]
as1 [Expr Id]
as2
= case InScopeEnv
-> [Id]
-> [Expr Id]
-> [Expr Id]
-> Maybe (Expr Id -> Expr Id, [Expr Id])
matchExprs InScopeEnv
ise [Id]
vs1 [Expr Id]
as1 [Expr Id]
as2 of
Just (Expr Id -> Expr Id
_, [Expr Id]
ms) -> (Expr Id -> Bool) -> [Expr Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Expr Id -> Bool
exprIsTrivial [Expr Id]
ms
Maybe (Expr Id -> Expr Id, [Expr Id])
Nothing -> Bool
False
| Bool
otherwise
= Bool
False
where
ise :: InScopeEnv
ise = InScopeSet -> IdUnfoldingFun -> InScopeEnv
ISE (InScopeSet
is InScopeSet -> [Id] -> InScopeSet
`extendInScopeSetList` [Id]
vs2) (Unfolding -> IdUnfoldingFun
forall a b. a -> b -> a
const Unfolding
noUnfolding)
subsumePats :: InScopeSet -> [CallPat] -> [CallPat]
subsumePats :: InScopeSet -> [CallPat] -> [CallPat]
subsumePats InScopeSet
is [CallPat]
pats = ([CallPat] -> CallPat -> [CallPat])
-> [CallPat] -> [CallPat] -> [CallPat]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [CallPat] -> CallPat -> [CallPat]
add [] [CallPat]
pats
where
add :: [CallPat] -> CallPat -> [CallPat]
add :: [CallPat] -> CallPat -> [CallPat]
add [] CallPat
ci = [CallPat
ci]
add (CallPat
ci1:[CallPat]
cis) CallPat
ci2 | InScopeSet -> CallPat -> CallPat -> Bool
betterPat InScopeSet
is CallPat
ci1 CallPat
ci2 = CallPat
ci1 CallPat -> [CallPat] -> [CallPat]
forall a. a -> [a] -> [a]
: [CallPat]
cis
| InScopeSet -> CallPat -> CallPat -> Bool
betterPat InScopeSet
is CallPat
ci2 CallPat
ci1 = CallPat
ci2 CallPat -> [CallPat] -> [CallPat]
forall a. a -> [a] -> [a]
: [CallPat]
cis
| Bool
otherwise = CallPat
ci1 CallPat -> [CallPat] -> [CallPat]
forall a. a -> [a] -> [a]
: [CallPat] -> CallPat -> [CallPat]
add [CallPat]
cis CallPat
ci2