-- for details
module SpecConstr(
- specConstrProgram, SpecConstrAnnotation(..)
+ specConstrProgram
+#ifdef GHCI
+ , SpecConstrAnnotation(..)
+#endif
) where
#include "HsVersions.h"
import CoreMonad
import HscTypes ( ModGuts(..) )
import WwLib ( mkWorkerArgs )
-import DataCon ( dataConTyCon, dataConRepArity, dataConUnivTyVars )
-import TyCon ( TyCon )
-import Literal ( literalType )
+import DataCon
import Coercion
import Rules
import Type hiding( substTy )
import Id
-import MkId ( mkImpossibleExpr )
+import MkCore ( mkImpossibleExpr )
import Var
import VarEnv
import VarSet
import Name
+import BasicTypes
import DynFlags ( DynFlags(..) )
import StaticFlags ( opt_PprStyle_Debug )
import Maybes ( orElse, catMaybes, isJust, isNothing )
import Outputable
import FastString
import UniqFM
-import qualified LazyUniqFM as L
import MonadUtils
import Control.Monad ( zipWithM )
import Data.List
-#if __GLASGOW_HASKELL__ > 609
-import Data.Data ( Data, Typeable )
+
+
+-- See Note [SpecConstrAnnotation]
+#ifndef GHCI
+type SpecConstrAnnotation = ()
#else
-import Data.Generics ( Data, Typeable )
+import Literal ( literalType )
+import TyCon ( TyCon )
+import GHC.Exts( SpecConstrAnnotation(..) )
#endif
\end{code}
and hence f. But now f's strictness is less than its arity, which
breaks an invariant.
+Note [SpecConstrAnnotation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+SpecConstrAnnotation is defined in GHC.Exts, and is only guaranteed to
+be available in stage 2 (well, until the bootstrap compiler can be
+guaranteed to have it)
+
+So we define it to be () in stage1 (ie when GHCI is undefined), and
+'#ifdef' out the code that uses it.
+
+See also Note [Forcing specialisation]
+
+Note [Forcing specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With stream fusion and in other similar cases, we want to fully specialise
+some (but not necessarily all!) loops regardless of their size and the
+number of specialisations. We allow a library to specify this by annotating
+a type with ForceSpecConstr and then adding a parameter of that type to the
+loop. Here is a (simplified) example from the vector library:
+
+ data SPEC = SPEC | SPEC2
+ {-# ANN type SPEC ForceSpecConstr #-}
+
+ foldl :: (a -> b -> a) -> a -> Stream b -> a
+ {-# INLINE foldl #-}
+ foldl f z (Stream step s _) = foldl_loop SPEC z s
+ where
+ foldl_loop SPEC z s = case step s of
+ Yield x s' -> foldl_loop SPEC (f z x) s'
+ Skip -> foldl_loop SPEC z s'
+ Done -> z
+
+SpecConstr will spot the SPEC parameter and always fully specialise
+foldl_loop. Note that we can't just annotate foldl_loop since it isn't a
+top-level function but even if we could, inlining etc. could easily drop the
+annotation. We also have to prevent the SPEC argument from being removed by
+w/w which is why SPEC is a sum type. This is all quite ugly; we ought to come
+up with a better design.
+
+ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
+force_spec to True when calling specLoop. This flag makes specLoop and
+specialise ignore specConstrCount and specConstrThreshold when deciding
+whether to specialise a function.
+
-----------------------------------------------------
Stuff not yet handled
-----------------------------------------------------
%************************************************************************
%* *
-\subsection{Annotations}
-%* *
-%************************************************************************
-
-Annotating a type with NoSpecConstr will make SpecConstr not specialise
-for arguments of that type.
-
-\begin{code}
-data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr
- deriving( Data, Typeable, Eq )
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Top level wrapper stuff}
%* *
%************************************************************************
-- Domain is OutIds (*after* applying the substitution)
-- Used even for top-level bindings (but not imported ones)
- sc_annotations :: L.UniqFM SpecConstrAnnotation
+ sc_annotations :: UniqFM SpecConstrAnnotation
}
---------------------
---------------------
type ValueEnv = IdEnv Value -- Domain is OutIds
data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
+ -- The AltCon is never DEFAULT
| LambdaVal -- Inlinable lambdas or PAPs
instance Outputable Value where
ppr LambdaVal = ptext (sLit "<Lambda>")
---------------------
-initScEnv :: DynFlags -> L.UniqFM SpecConstrAnnotation -> ScEnv
+initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
initScEnv dflags anns
= SCE { sc_size = specConstrThreshold dflags,
sc_count = specConstrCount dflags,
-- Var v -> extendValEnv env1 v cval
-- _other -> env1
where
- zap v | isTyVar v = v -- See NB2 above
+ zap v | isTyCoVar v = v -- See NB2 above
| otherwise = zapIdOccInfo v
env1 = extendValEnv env case_bndr cval
cval = case con of
vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
varsToCoreExprs alt_bndrs
-ignoreTyCon :: ScEnv -> TyCon -> Bool
-ignoreTyCon env tycon
- = L.lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
-ignoreType :: ScEnv -> Type -> Bool
+decreaseSpecCount :: ScEnv -> Int -> ScEnv
+-- See Note [Avoiding exponential blowup]
+decreaseSpecCount env n_specs
+ = env { sc_count = case sc_count env of
+ Nothing -> Nothing
+ Just n -> Just (n `div` (n_specs + 1)) }
+ -- The "+1" takes account of the original function;
+ -- See Note [Avoiding exponential blowup]
+
+---------------------------------------------------
+-- See Note [SpecConstrAnnotation]
+ignoreType :: ScEnv -> Type -> Bool
+ignoreAltCon :: ScEnv -> AltCon -> Bool
+forceSpecBndr :: ScEnv -> Var -> Bool
+#ifndef GHCI
+ignoreType _ _ = False
+ignoreAltCon _ _ = False
+forceSpecBndr _ _ = False
+
+#else /* GHCI */
+
+ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
+ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
+ignoreAltCon _ DEFAULT = panic "ignoreAltCon" -- DEFAULT cannot be in a ConVal
+
ignoreType env ty
= case splitTyConApp_maybe ty of
Just (tycon, _) -> ignoreTyCon env tycon
_ -> False
-ignoreAltCon :: ScEnv -> AltCon -> Bool
-ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
-ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
-ignoreAltCon _ DEFAULT = True
+ignoreTyCon :: ScEnv -> TyCon -> Bool
+ignoreTyCon env tycon
+ = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
-forceSpecBndr :: ScEnv -> Var -> Bool
forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
forceSpecFunTy :: ScEnv -> Type -> Bool
forceSpecArgTy env ty
| Just (tycon, tys) <- splitTyConApp_maybe ty
, tycon /= funTyCon
- = L.lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
+ = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
|| any (forceSpecArgTy env) tys
forceSpecArgTy _ _ = False
-
-decreaseSpecCount :: ScEnv -> Int -> ScEnv
--- See Note [Avoiding exponential blowup]
-decreaseSpecCount env n_specs
- = env { sc_count = case sc_count env of
- Nothing -> Nothing
- Just n -> Just (n `div` (n_specs + 1)) }
- -- The "+1" takes account of the original function;
- -- See Note [Avoiding exponential blowup]
+#endif /* GHCI */
\end{code}
Note [Avoiding exponential blowup]
; return (usg', scrut_occ, (con, bs2, rhs')) }
scExpr' env (Let (NonRec bndr rhs) body)
- | isTyVar bndr -- Type-lets may be created by doBeta
+ | isTyCoVar bndr -- Type-lets may be created by doBeta
= scExpr' (extendScSubst env bndr rhs) body
- | otherwise -- Note [Local let bindings]
+ | otherwise
= do { let (body_env, bndr') = extendBndr env bndr
- body_env2 = extendHowBound body_env [bndr'] RecFun
- ; (body_usg, body') <- scExpr body_env2 body
-
; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
+ ; let body_env2 = extendHowBound body_env [bndr'] RecFun
+ -- Note [Local let bindings]
+ RI _ rhs' _ _ _ = rhs_info
+ body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
+
+ ; (body_usg, body') <- scExpr body_env3 body
+
+ -- NB: We don't use the ForceSpecConstr mechanism (see
+ -- Note [Forcing specialisation]) for non-recursive bindings
+ -- at the moment. I'm not sure if this is the right thing to do.
; let force_spec = False
; (spec_usg, specs) <- specialise env force_spec
(scu_calls body_usg)
(rhs_env1,bndrs') = extendRecBndrs env bndrs
rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
force_spec = any (forceSpecBndr env) bndrs'
+ -- Note [Forcing specialisation]
; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
; (body_usg, body') <- scExpr rhs_env2 body
where
(bndrs,rhss) = unzip prs
force_spec = any (forceSpecBndr env) bndrs
+ -- Note [Forcing specialisation]
scTopBind env (NonRec bndr rhs)
= do { (_, rhs') <- scExpr env rhs
specLoop :: ScEnv
-> Bool -- force specialisation?
+ -- Note [Forcing specialisation]
-> CallEnv
-> [RhsInfo]
-> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
specialise
:: ScEnv
-> Bool -- force specialisation?
+ -- Note [Forcing specialisation]
-> CallEnv -- Info on calls
-> RhsInfo
-> SpecInfo -- Original RHS plus patterns dealt with
specialise env force_spec bind_calls (RI fn _ arg_bndrs body arg_occs)
spec_info@(SI specs spec_count mb_unspec)
| not (isBottomingId fn) -- Note [Do not specialise diverging functions]
+ , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]
, notNull arg_bndrs -- Only specialise functions
, Just all_calls <- lookupVarEnv bind_calls fn
= do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
body_ty = exprType spec_body
rule_rhs = mkVarApps (Var spec_id) spec_call_args
inline_act = idInlineActivation fn
- rule = mkLocalRule rule_name inline_act fn_name qvars pats rule_rhs
+ rule = mkRule True {- Auto -} True {- Local -}
+ rule_name inline_act fn_name qvars pats rule_rhs
+ -- See Note [Transfer activation]
; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
calcSpecStrictness :: Id -- The original function
Note [Transfer activation]
~~~~~~~~~~~~~~~~~~~~~~~~~~
+ This note is for SpecConstr, but exactly the same thing
+ happens in the overloading specialiser; see
+ Note [Auto-specialisation and RULES] in Specialise.
+
In which phase should the specialise-constructor rules be active?
Originally I made them always-active, but Manuel found that this
defeated some clever user-written rules. Then I made them active only
So now I just use the inline-activation of the parent Id, as the
activation for the specialiation RULE, just like the main specialiser;
-see Note [Auto-specialisation and RULES] in Specialise.
+This in turn means there is no point in specialising NOINLINE things,
+so we test for that.
Note [Transfer strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~
-- at the call site
-- See Note [Shadowing] at the top
- (tvs, ids) = partition isTyVar qvars
+ (tvs, ids) = partition isTyCoVar qvars
qvars' = tvs ++ ids
-- Put the type variables first; the type of a term
-- variable may mention a type variable
argToPat env in_scope val_env (Let _ arg) arg_occ
= argToPat env in_scope val_env arg arg_occ
+ -- See Note [Matching lets] in Rule.lhs
-- Look through let expressions
- -- e.g. f (let v = rhs in \y -> ...v...)
- -- Here we can specialise for f (\y -> ...)
+ -- e.g. f (let v = rhs in (v,w))
+ -- Here we can specialise for f (v,w)
-- because the rule-matcher will look through the let.
+{- Disabled; see Note [Matching cases] in Rule.lhs
+argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
+ | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs
+ = argToPat env in_scope val_env rhs arg_occ
+-}
+
argToPat env in_scope val_env (Cast arg co) arg_occ
| not (ignoreType env ty2)
= do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
-- as well, for let-bound constructors!
isValue env (Lam b e)
- | isTyVar b = case isValue env e of
+ | isTyCoVar b = case isValue env e of
Just _ -> Just LambdaVal
Nothing -> Nothing
| otherwise = Just LambdaVal