X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=2d95ae7d81595da23ba7ab9b51100d13de4bed61;hb=baa26ed728b6164f2827a97133306131aa89ed6f;hp=03038337268fc8a93b4aa44e7c7d318cc73acd7b;hpb=2a8123e1eaac6198fdf1c029561dddffc1ab2cff;p=ghc-hetmet.git

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 0303833..2d95ae7 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -29,7 +29,7 @@ module Rules (
 	addIdSpecialisations, 
 	
 	-- * Misc. CoreRule helpers
-        rulesOfBinds,
+        rulesOfBinds, getRules, pprRulesForUser,
         
         lookupRule, mkLocalRule, roughTopNames
     ) where
@@ -152,6 +152,22 @@ ruleCantMatch (t       : ts) (a       : as) = ruleCantMatch ts as
 ruleCantMatch ts	     as		    = False
 \end{code}
 
+\begin{code}
+pprRulesForUser :: [CoreRule] -> SDoc
+-- (a) tidy the rules
+-- (b) sort them into order based on the rule name
+-- (c) suppress uniques (unless -dppr-debug is on)
+-- This combination makes the output stable so we can use in testing
+-- It's here rather than in PprCore because it calls tidyRules
+pprRulesForUser rules
+  = withPprStyle defaultUserStyle $
+    pprRules $
+    sortLe le_rule  $
+    tidyRules emptyTidyEnv rules
+  where 
+    le_rule r1 r2 = ru_name r1 <= ru_name r2
+\end{code}
+
 
 %************************************************************************
 %*									*
@@ -168,7 +184,6 @@ mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules)
 extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
 extendSpecInfo (SpecInfo rs1 fvs1) rs2
   = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
-
 addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
 addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2) 
   = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
@@ -181,6 +196,18 @@ addIdSpecialisations id rules
 -- | Gather all the rules for locally bound identifiers from the supplied bindings
 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)
+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
 \end{code}
 
 
@@ -241,37 +268,17 @@ in the Simplifier works better as it is.  Reason: the 'args' passed
 to lookupRule are the result of a lazy substitution
 
 \begin{code}
--- | The main rule matching function. Attempts to apply all the active
--- rules in a given 'RuleBase' to this instance of an application
--- in a given context, returning the rule applied and the resulting
--- expression if successful.
-lookupRule :: (Activation -> Bool)  -- ^ Activation test
-           -> InScopeSet                -- ^ Variables that are in scope at this point
-	   -> RuleBase	                -- ^ Imported rules
-	   -> Id                        -- ^ Function 'Id' to lookup a rule by
-	   -> [CoreExpr]                -- ^ Arguments to function
-	   -> Maybe (CoreRule, CoreExpr)
--- See Note [Extra argsin rule matching]
-lookupRule is_active in_scope rule_base fn args
-  = matchRules is_active in_scope fn args (getRules rule_base fn)
-
-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)
-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
-
-matchRules :: (Activation -> Bool) -> InScopeSet
-	   -> Id -> [CoreExpr]
-	   -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
+-- | The main rule matching function. Attempts to apply all (active)
+-- supplied rules to this instance of an application in a given
+-- context, returning the rule applied and the resulting expression if
+-- successful.
+lookupRule :: (Activation -> Bool) -> InScopeSet
+	    -> Id -> [CoreExpr]
+	    -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
+
+-- See Note [Extra args in rule matching]
 -- See comments on matchRule
-matchRules is_active in_scope fn args rules
+lookupRule is_active in_scope fn args rules
   = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
     case go [] rules of
 	[]     -> Nothing
@@ -284,7 +291,7 @@ matchRules is_active in_scope fn args rules
     go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of
 			Just e  -> go ((r,e):ms) rs
 			Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$ 
-				   --	ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] )
+				   -- 	ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] )
 				   go ms         rs
 
 findBest :: (Id, [CoreExpr])