X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=a2ef2a19b37b22670ba8ab38012c6063b05369a8;hp=84f8698188be323c5585e3e1d096f1182271012f;hb=707ea5881703d680155aab268bdbf7edc113e3b1;hpb=f03b9562a92c6ef94c603a334d5d5e1cd2165c92 diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 84f8698..a2ef2a19 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -11,7 +11,10 @@ -- for details module SpecConstr( - specConstrProgram, SpecConstrAnnotation(..) + specConstrProgram +#ifdef GHCI + , SpecConstrAnnotation(..) +#endif ) where #include "HsVersions.h" @@ -24,14 +27,12 @@ import CoreFVs ( exprsFreeVars ) 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 @@ -51,7 +52,16 @@ import UniqFM 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} ----------------------------------------------------- @@ -385,6 +395,17 @@ But fspec doesn't have decent strictnes info. As it happened, 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 @@ -494,20 +515,6 @@ unbox the strict fields, becuase T is polymorphic!) %************************************************************************ %* * -\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} %* * %************************************************************************ @@ -569,6 +576,7 @@ type HowBoundEnv = VarEnv HowBound -- Domain is OutVars --------------------- 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 @@ -672,7 +680,7 @@ extendCaseBndrs env case_bndr con alt_bndrs -- 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 @@ -683,22 +691,41 @@ extendCaseBndrs env case_bndr con alt_bndrs 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 @@ -715,15 +742,7 @@ forceSpecArgTy env ty || 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] @@ -936,16 +955,20 @@ scExpr' env (Case scrut b ty alts) ; 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. @@ -1279,7 +1302,8 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) 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) } @@ -1398,7 +1422,7 @@ callToPats env bndr_occs (con_env, args) -- 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 @@ -1572,7 +1596,7 @@ isValue env (Var v) -- 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