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 )
-#else
-import Data.Generics ( Data, Typeable )
-#endif
\end{code}
-----------------------------------------------------
and hence f. But now f's strictness is less than its arity, which
breaks an invariant.
+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
-----------------------------------------------------
-- 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
}
---------------------
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,
ignoreTyCon :: ScEnv -> TyCon -> Bool
ignoreTyCon env tycon
- = L.lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
+ = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
ignoreType :: ScEnv -> Type -> Bool
ignoreType env ty
ignoreAltCon _ DEFAULT = True
forceSpecBndr :: ScEnv -> Var -> Bool
-forceSpecBndr env var = forceSpecFunTy env . varType $ var
+forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
forceSpecFunTy :: ScEnv -> Type -> Bool
forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
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
; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
+ -- 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
Note [Specialise original body]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The RhsInfo for a binding keeps the *oringal* body of the binding. We
+The RhsInfo for a binding keeps the *original* body of the binding. We
must specialise that, *not* the result of applying specExpr to the RHS
(which is also kept in RhsInfo). Otherwise we end up specialising a
specialised RHS, and that can lead directly to exponential behaviour.