X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=84f8698188be323c5585e3e1d096f1182271012f;hb=f03b9562a92c6ef94c603a334d5d5e1cd2165c92;hp=219e758c4aa0f36210d2cc733c41b65ae6c8d9e5;hpb=59b01a2fb6cd6a9af37f5fd6775f574bc53af02a;p=ghc-hetmet.git

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 219e758..84f8698 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -36,6 +36,7 @@ import Var
 import VarEnv
 import VarSet
 import Name
+import BasicTypes
 import DynFlags		( DynFlags(..) )
 import StaticFlags	( opt_PprStyle_Debug )
 import Maybes		( orElse, catMaybes, isJust, isNothing )
@@ -47,15 +48,10 @@ import UniqSupply
 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}
 
 -----------------------------------------------------
@@ -555,7 +551,7 @@ data ScEnv = SCE { sc_size  :: Maybe Int,	-- Size threshold
 			-- 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
 	     }
 
 ---------------------
@@ -580,7 +576,7 @@ 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,
@@ -689,7 +685,7 @@ extendCaseBndrs env case_bndr con alt_bndrs
 
 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
@@ -715,7 +711,7 @@ forceSpecArgTy env ty
 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
@@ -1177,6 +1173,7 @@ specialise
 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
@@ -1283,6 +1280,7 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
 	      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
+	      		   -- See Note [Transfer activation]
 	; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
 
 calcSpecStrictness :: Id 		     -- The original function
@@ -1318,6 +1316,10 @@ specialised RHS, and that can lead directly to exponential behaviour.
 
 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
@@ -1328,8 +1330,9 @@ simplCore/should_compile/spec-inline.
 
 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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1441,11 +1444,18 @@ argToPat env in_scope val_env (Note _ arg) arg_occ
 
 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