-- 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 MonadUtils
import Control.Monad ( zipWithM )
import Data.List
-import Data.Data ( Data, Typeable )
+
+
+-- See Note [SpecConstrAnnotation]
+#ifndef GHCI
+type SpecConstrAnnotation = ()
+#else
+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
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
---------------------
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
-- 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
- = 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
|| 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.
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) }
-- 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
-- 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
projects / ghc-hetmet.git / blobdiff