X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=cc5054a10c5dc5ed98d8b6cad9a29f750512dcc1;hb=d4b4b5bd0918cb1181b6d3f6149cf16e61b18c8e;hp=0cf7a445b87fa8a226d19462baad33dc91978f66;hpb=4bc25e8c30559b7a6a87b39afcc79340ae778788;p=ghc-hetmet.git

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 0cf7a44..cc5054a 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -22,9 +22,9 @@ module Rules (
 	addIdSpecialisations, 
 	
 	-- * Misc. CoreRule helpers
-        rulesOfBinds, getRules, pprRulesForUser,
+        rulesOfBinds, getRules, pprRulesForUser, expandId,
         
-        lookupRule, mkLocalRule, roughTopNames
+        lookupRule, mkRule, mkLocalRule, roughTopNames
     ) where
 
 #include "HsVersions.h"
@@ -96,11 +96,18 @@ mkLocalRule :: RuleName -> Activation
 	    -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
 -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being 
 -- compiled. See also 'CoreSyn.CoreRule'
-mkLocalRule name act fn bndrs args rhs
+mkLocalRule = mkRule True
+
+mkRule :: Bool -> RuleName -> Activation 
+       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
+-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being 
+-- compiled. See also 'CoreSyn.CoreRule'
+mkRule is_local name act fn bndrs args rhs
   = Rule { ru_name = name, ru_fn = fn, ru_act = act,
 	   ru_bndrs = bndrs, ru_args = args,
-	   ru_rhs = rhs, ru_rough = roughTopNames args,
-	   ru_local = True }
+	   ru_rhs = occurAnalyseExpr rhs, 
+	   ru_rough = roughTopNames args,
+	   ru_local = is_local }
 
 --------------
 roughTopNames :: [CoreExpr] -> [Maybe Name]
@@ -192,18 +199,32 @@ rulesOfBinds :: [CoreBind] -> [CoreRule]
 rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
 
 getRules :: RuleBase -> Id -> [CoreRule]
-	-- The rules for an Id come from two places:
-	--	(a) the ones it is born with (idCoreRules fn)
-	--	(b) rules added in subsequent modules (extra_rules)
-	-- PrimOps, for example, are born with a bunch of rules under (a)
+-- See Note [Where rules are found]
 getRules rule_base fn
-  | isLocalId fn  = idCoreRules fn
-  | otherwise     = WARN( not (isPrimOpId fn) && notNull (idCoreRules fn), 
- 			  ppr fn <+> ppr (idCoreRules fn) )
-		    idCoreRules fn ++ (lookupNameEnv rule_base (idName fn) `orElse` [])
-	-- Only PrimOpIds have rules inside themselves, and perhaps more besides
+  = idCoreRules fn ++ imp_rules
+  where
+    imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []
 \end{code}
 
+Note [Where rules are found]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The rules for an Id come from two places:
+  (a) the ones it is born with, stored inside the Id iself (idCoreRules fn),
+  (b) rules added in other modules, stored in the global RuleBase (imp_rules)
+
+It's tempting to think that 
+     - LocalIds have only (a)
+     - non-LocalIds have only (b)
+
+but that isn't quite right:
+
+     - PrimOps and ClassOps are born with a bunch of rules inside the Id,
+       even when they are imported
+
+     - The rules in PrelRules.builtinRules should be active even
+       in the module defining the Id (when it's a LocalId), but 
+       the rules are kept in the global RuleBase
+
 
 %************************************************************************
 %*									*
@@ -355,6 +376,7 @@ matchRule :: (Activation -> Bool) -> InScopeSet
 
 matchRule _is_active _in_scope args _rough_args
 	  (BuiltinRule { ru_try = match_fn })
+-- Built-in rules can't be switched off, it seems
   = case match_fn args of
 	Just expr -> Just expr
 	Nothing   -> Nothing
@@ -488,9 +510,10 @@ match menv subst (Var v1) e2
   | Just subst <- match_var menv subst v1 e2
   = Just subst
 
-match menv subst e1 (Note _ e2)
-  = match menv subst e1 e2
-	-- See Note [Notes in RULE matching]
+match menv subst (Note _ e1) e2 = match menv subst e1 e2
+match menv subst e1 (Note _ e2) = match menv subst e1 e2
+      -- Ignore notes in both template and thing to be matched
+      -- See Note [Notes in RULE matching]
 
 match menv subst e1 (Var v2)      -- Note [Expanding variables]
   | not (locallyBoundR rn_env v2) -- Note [Do not expand locally-bound variables]
@@ -566,7 +589,7 @@ match menv subst (Cast e1 co1) (Cast e2 co2)
 	; match menv subst1 e1 e2 }
 
 -- Everything else fails
-match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr e1) $$ (text "e2:" <+> ppr e2)) $ 
+match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ 
 			 Nothing
 
 ------------------------------------------
@@ -684,11 +707,11 @@ Hence, (a) the guard (not (isLocallyBoundR v2))
 
 Note [Notes in RULE matching]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Look through Notes.  In particular, we don't want to
-be confused by InlineMe notes.  Maybe we should be more
-careful about profiling notes, but for now I'm just
-riding roughshod over them.  
-See Note [Notes in call patterns] in SpecConstr
+Look through Notes in both template and expression being matched.  In
+particular, we don't want to be confused by InlineMe notes.  Maybe we
+should be more careful about profiling notes, but for now I'm just
+riding roughshod over them.  cf Note [Notes in call patterns] in
+SpecConstr
 
 Note [Matching lets]
 ~~~~~~~~~~~~~~~~~~~~