Improve warnings for rules that might not fire
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 24 Jul 2015 11:50:42 +0000 (12:50 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 27 Jul 2015 13:02:33 +0000 (14:02 +0100)
Two main things here

* Previously we only warned about the "head" function of the rule,
  but actually the warning applies to any free variable on the LHS.

* We now warn not only when one of these free vars can inline, but
  also if it has an active RULE (c.f. Trac #10528)

See Note [Rules and inlining/other rules] in Desugar

This actually shows up quite a few warnings in the libraries, notably
in Control.Arrow, where it correctly points out that rules like
    "compose/arr"   forall f g .
                    (arr f) . (arr g) = arr (f . g)
might never fire, because the rule for 'arr' (dictionary selection)
might fire first.  I'm not really sure what to do here; there is some
discussion in Trac #10595.

A minor change is adding BasicTypes.pprRuleName to pretty-print RuleName.

compiler/basicTypes/BasicTypes.hs
compiler/deSugar/Desugar.hs
compiler/iface/IfaceSyn.hs
compiler/iface/TcIface.hs
compiler/typecheck/TcRnTypes.hs
testsuite/tests/indexed-types/should_compile/Rules1.hs
testsuite/tests/indexed-types/should_compile/T2291.hs
testsuite/tests/simplCore/should_compile/T5776.hs
testsuite/tests/simplCore/should_compile/T6082-RULE.stderr
testsuite/tests/simplCore/should_compile/T7287.hs
testsuite/tests/typecheck/should_compile/tc111.hs

index d15295d..8bcb0d9 100644 (file)
@@ -37,7 +37,7 @@ module BasicTypes(
         RecFlag(..), isRec, isNonRec, boolToRecFlag,
         Origin(..), isGenerated,
 
-        RuleName,
+        RuleName, pprRuleName,
 
         TopLevelFlag(..), isTopLevel, isNotTopLevel,
 
@@ -68,8 +68,10 @@ module BasicTypes(
         SwapFlag(..), flipSwap, unSwap, isSwapped,
 
         CompilerPhase(..), PhaseNum,
-        Activation(..), isActive, isActiveIn,
+
+        Activation(..), isActive, isActiveIn, competesWith,
         isNeverActive, isAlwaysActive, isEarlyActive,
+
         RuleMatchInfo(..), isConLike, isFunLike,
         InlineSpec(..), isEmptyInlineSpec,
         InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
@@ -291,6 +293,9 @@ instance Outputable WarningTxt where
 
 type RuleName = FastString
 
+pprRuleName :: RuleName -> SDoc
+pprRuleName rn = doubleQuotes (ftext rn)
+
 {-
 ************************************************************************
 *                                                                      *
@@ -877,7 +882,7 @@ instance Outputable CompilerPhase where
 
 data Activation = NeverActive
                 | AlwaysActive
-                | ActiveBefore PhaseNum -- Active only *before* this phase
+                | ActiveBefore PhaseNum -- Active only *strictly before* this phase
                 | ActiveAfter PhaseNum  -- Active in this phase and later
                 deriving( Eq, Data, Typeable )  -- Eq used in comparing rules in HsDecls
 
@@ -1078,6 +1083,34 @@ isActiveIn _ AlwaysActive     = True
 isActiveIn p (ActiveAfter n)  = p <= n
 isActiveIn p (ActiveBefore n) = p >  n
 
+competesWith :: Activation -> Activation -> Bool
+-- See Note [Activation competition]
+competesWith NeverActive       _                = False
+competesWith _                 NeverActive      = False
+competesWith AlwaysActive      _                = True
+
+competesWith (ActiveBefore {}) AlwaysActive      = True
+competesWith (ActiveBefore {}) (ActiveBefore {}) = True
+competesWith (ActiveBefore a)  (ActiveAfter b)   = a > b
+
+competesWith (ActiveAfter {})  AlwaysActive      = False
+competesWith (ActiveAfter {})  (ActiveBefore {}) = False
+competesWith (ActiveAfter a)   (ActiveAfter b)   = a >= b
+
+{- Note [Competing activations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Sometimes a RULE and an inlining may compete, or two RULES.
+See Note [Rules and inlining/other rules] in Desugar.
+
+We say that act1 "competes with" act2 iff
+   act1 is active in the phase when act2 *becomes* active
+
+It's too conservative to ensure that the two are never simultaneously
+active.  For example, a rule might be always active, and an inlining
+might switch on in phase 2.  We could switch off the rule, but it does
+no harm.
+-}
+
 isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool
 isNeverActive NeverActive = True
 isNeverActive _           = False
index 9d751fc..6dbdfca 100644 (file)
@@ -25,6 +25,7 @@ import InstEnv
 import Class
 import Avail
 import CoreSyn
+import CoreFVs( exprsSomeFreeVars )
 import CoreSubst
 import PprCore
 import DsMonad
@@ -37,10 +38,11 @@ import NameEnv
 import Rules
 import TysPrim (eqReprPrimTyCon)
 import TysWiredIn (coercibleTyCon )
-import BasicTypes       ( Activation(.. ) )
+import BasicTypes       ( Activation(.. ), competesWith, pprRuleName )
 import CoreMonad        ( CoreToDo(..) )
 import CoreLint         ( endPassIO )
 import MkCore
+import VarSet
 import FastString
 import ErrUtils
 import Outputable
@@ -346,7 +348,7 @@ Reason
 -}
 
 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
-dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
+dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
   = putSrcSpanDs loc $
     do  { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
 
@@ -355,7 +357,6 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
 
         ; rhs' <- dsLExpr rhs
-        ; dflags <- getDynFlags
         ; this_mod <- getModule
 
         ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
@@ -372,35 +373,55 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
                 -- because they don't show up in the bindings until just before code gen
               fn_name   = idName fn_id
               final_rhs = simpleOptExpr rhs''    -- De-crap it
+              rule_name = snd (unLoc name)
               rule      = mkRule this_mod False {- Not auto -} is_local
-                                 (snd $ unLoc name) act fn_name final_bndrs args
+                                 rule_name rule_act fn_name final_bndrs args
                                  final_rhs
+              arg_ids = varSetElems (exprsSomeFreeVars isId args `delVarSetList` final_bndrs)
+
+        ; dflags <- getDynFlags
+        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
+          warnRuleShadowing rule_name rule_act fn_id arg_ids
 
-              inline_shadows_rule   -- Function can be inlined before rule fires
-                | wopt Opt_WarnInlineRuleShadowing dflags
-                , isLocalId fn_id || hasSomeUnfolding (idUnfolding fn_id)
+        ; return (Just rule)
+        } } }
+
+
+warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
+-- See Note [Rules and inlining/other rules]
+warnRuleShadowing rule_name rule_act fn_id arg_ids
+  = do { check False fn_id    -- We often have multiple rules for the same Id in a
+                              -- module. Maybe we should check that they don't overlap
+                              -- but currently we don't
+       ; mapM_ (check True) arg_ids }
+  where
+    check check_rules_too lhs_id
+      | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
                        -- If imported with no unfolding, no worries
-                = case (idInlineActivation fn_id, act) of
-                    (NeverActive, _)    -> False
-                    (AlwaysActive, _)   -> True
-                    (ActiveBefore {}, _) -> True
-                    (ActiveAfter {}, NeverActive)     -> True
-                    (ActiveAfter n, ActiveAfter r)    -> r < n  -- Rule active strictly first
-                    (ActiveAfter {}, AlwaysActive)    -> False
-                    (ActiveAfter {}, ActiveBefore {}) -> False
-                | otherwise = False
-
-        ; when inline_shadows_rule $
-          warnDs (vcat [ hang (ptext (sLit "Rule")
-                               <+> doubleQuotes (ftext $ snd $ unLoc name)
+      , idInlineActivation lhs_id `competesWith` rule_act
+      = warnDs (vcat [ hang (ptext (sLit "Rule") <+> pprRuleName rule_name
                                <+> ptext (sLit "may never fire"))
-                            2 (ptext (sLit "because") <+> quotes (ppr fn_id)
+                            2 (ptext (sLit "because") <+> quotes (ppr lhs_id)
                                <+> ptext (sLit "might inline first"))
-                       , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma on")
-                         <+> quotes (ppr fn_id) ])
+                     , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for")
+                       <+> quotes (ppr lhs_id) ])
 
-        ; return (Just rule)
-        } } }
+      | check_rules_too
+      , bad_rule : _ <- get_bad_rules lhs_id
+      = warnDs (vcat [ hang (ptext (sLit "Rule") <+> pprRuleName rule_name
+                               <+> ptext (sLit "may never fire"))
+                            2 (ptext (sLit "because rule") <+> pprRuleName (ruleName bad_rule)
+                               <+> ptext (sLit "for")<+> quotes (ppr lhs_id)
+                               <+> ptext (sLit "might fire first"))
+                      , ptext (sLit "Probable fix: add phase [n] or [~n] to the competing rule")
+                      , ifPprDebug (ppr bad_rule) ])
+
+      | otherwise
+      = return ()
+
+    get_bad_rules lhs_id
+      = [ rule | rule <- idCoreRules lhs_id
+               , ruleActivation rule `competesWith` rule_act ]
 
 -- See Note [Desugaring coerce as cast]
 unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
@@ -422,9 +443,8 @@ unfold_coerce bndrs lhs rhs = do
             (bndrs,wrap) <- go vs
             return (v:bndrs, wrap)
 
-{-
-Note [Desugaring RULE left hand sides]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Desugaring RULE left hand sides]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For the LHS of a RULE we do *not* want to desugar
     [x]   to    build (\cn. x `c` n)
 We want to leave explicit lists simply as chains
@@ -439,7 +459,6 @@ Nor do we want to warn of conversion identities on the LHS;
 the rule is precisly to optimise them:
   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
 
-
 Note [Desugaring coerce as cast]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We want the user to express a rule saying roughly “mapping a coercion over a
@@ -454,6 +473,42 @@ corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
 `let c = MkCoercible co in ...`. This is later simplified to the desired form
 by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
 
+Note [Rules and inlining/other rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you have
+  f x = ...
+  g x = ...
+  {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
+then there's a good chance that in a potential rule redex
+    ...f (g e)...
+then 'f' or 'g' will inline befor the rule can fire.  Solution: add an
+INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.
+
+Note that this applies to all the free variables on the LHS, both the
+main function and things in its arguments.
+
+We also check if there are Ids on the LHS that have competing RULES.
+In the above example, suppose we had
+  {-# RULES "rule-for-g" forally. g [y] = ... #-}
+Then "rule-for-f" and "rule-for-g" would compete.  Better to add phase
+control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
+active; or perhpas after "rule-for-g" has become inactive. This is checked
+by 'competesWith'
+
+Class methods have a built-in RULE to select the method from the dictionary,
+so you can't change the phase on this.  That makes id very dubious to
+match on class methods in RULE lhs's.   See Trac #10595.   I'm not happy
+about this. For exmaple in Control.Arrow we have
+
+{-# RULES "compose/arr"   forall f g .
+                          (arr f) . (arr g) = arr (f . g) #-}
+
+and similar, which will elicit exactly these warnings, and risk never
+firing.  But it's not clear what to do instead.  We could make the
+class methocd rules inactive in phase 2, but that would delay when
+subsequent transformations could fire.
+
+
 ************************************************************************
 *                                                                      *
 *              Desugaring vectorisation declarations
index c5aa1a5..2673e11 100644 (file)
@@ -839,7 +839,7 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty
 instance Outputable IfaceRule where
   ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
                    ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
-    = sep [hsep [doubleQuotes (ftext name), ppr act,
+    = sep [hsep [pprRuleName name, ppr act,
                  ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
            nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
                         ptext (sLit "=") <+> ppr rhs])
index 3e97747..30ce0cd 100644 (file)
@@ -49,7 +49,8 @@ import DataCon
 import PrelNames
 import TysWiredIn
 import TysPrim          ( superKindTyConName )
-import BasicTypes       ( strongLoopBreaker, Arity, TupleSort(..), Boxity(..) )
+import BasicTypes       ( strongLoopBreaker, Arity, TupleSort(..)
+                        , Boxity(..), pprRuleName )
 import Literal
 import qualified Var
 import VarEnv
@@ -638,7 +639,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
                         ifRuleAuto = auto, ifRuleOrph = orph })
   = do  { ~(bndrs', args', rhs') <-
                 -- Typecheck the payload lazily, in the hope it'll never be looked at
-                forkM (ptext (sLit "Rule") <+> ftext name) $
+                forkM (ptext (sLit "Rule") <+> pprRuleName name) $
                 bindIfaceBndrs bndrs                      $ \ bndrs' ->
                 do { args' <- mapM tcIfaceExpr args
                    ; rhs'  <- tcIfaceExpr rhs
index 5547bbc..1f984e4 100644 (file)
@@ -2128,7 +2128,7 @@ pprSkolInfo (InstSC n)        = ptext (sLit "the instance declaration") <> ifPpr
 pprSkolInfo DataSkol          = ptext (sLit "a data type declaration")
 pprSkolInfo FamInstSkol       = ptext (sLit "a family instance declaration")
 pprSkolInfo BracketSkol       = ptext (sLit "a Template Haskell bracket")
-pprSkolInfo (RuleSkol name)   = ptext (sLit "the RULE") <+> doubleQuotes (ftext name)
+pprSkolInfo (RuleSkol name)   = ptext (sLit "the RULE") <+> pprRuleName name
 pprSkolInfo ArrowSkol         = ptext (sLit "an arrow form")
 pprSkolInfo (PatSkol cl mc)   = sep [ pprPatSkolInfo cl
                                     , ptext (sLit "in") <+> pprMatchContext mc ]
index afb8bc2..f650261 100644 (file)
@@ -10,6 +10,7 @@ instance (C a, C b) => C (a,b) where
   data T (a,b) = TPair (T a) (T b)
 
 mapT :: (C a, C b) => (a -> b) -> T a -> T b
+{-# NOINLINE mapT #-}  -- Otherwwise we get a warning from the rule
 mapT = undefined
 
 zipT :: (C a, C b) => T a -> T b -> T (a,b)
index e9aa877..99f48b4 100644 (file)
@@ -4,9 +4,21 @@ module Small where
 class CoCCC k where
         type Coexp k :: * -> * -> *
         type Sum k :: * -> * -> *
-        coapply :: k b (Sum k (Coexp k a b) a)
-        cocurry :: k c (Sum k a b) -> k (Coexp k b c) a
-        uncocurry :: k (Coexp k b c) a -> k c (Sum k a b)
+        coapply' :: k b (Sum k (Coexp k a b) a)
+        cocurry' :: k c (Sum k a b) -> k (Coexp k b c) a
+        uncocurry' :: k (Coexp k b c) a -> k c (Sum k a b)
+
+coapply   :: CoCCC k => k b (Sum k (Coexp k a b) a)
+{-# INLINE [1] coapply #-}
+coapply = coapply'
+
+cocurry   :: CoCCC k => k c (Sum k a b) -> k (Coexp k b c) a
+{-# INLINE [1] cocurry #-}
+cocurry = cocurry'
+
+uncocurry :: CoCCC k => k (Coexp k b c) a -> k c (Sum k a b)
+{-# INLINE [1] uncocurry #-}
+uncocurry = uncocurry'
 
 {-# RULES
 "cocurry coapply"               cocurry coapply = id
index df6444f..17a3e25 100644 (file)
@@ -3,26 +3,30 @@ module T5776 where
 -- The point about this test is that we should get a rule like this:
 -- "foo" [ALWAYS]
 --    forall (@ a)
---           ($dEq :: GHC.Classes.Eq a)
---           ($dEq1 :: GHC.Classes.Eq a)
+--           ($dEq  :: Eq a)
+--           ($dEq1 :: Eq a)
 --           (x :: a)
 --           (y :: a)
 --           (z :: a).
---      T5776.f (GHC.Classes.== @ a $dEq1 x y)
---              (GHC.Classes.== @ a $dEq y z)
+--      T5776.f (g @ a $dEq1 x y)
+--              (g @ a $dEq  y z)
 --      = GHC.Types.True
 --
 -- Note the *two* forall'd dEq parameters. This is important.
 -- See Note [Simplifying RULE lhs constraints] in TcSimplify
 
 {-# RULES "foo" forall x y z.
-      f (x == y) (y == z) = True
+      f (g x y) (g y z) = True
  #-}
 
+g :: Eq a => a -> a -> Bool
+{-# NOINLINE g #-}
+g = (==)
+
 f :: Bool -> Bool -> Bool
 {-# NOINLINE f #-}
 f a b = False
 
 blah :: Int -> Int -> Bool
-blah x y = f (x==y) (x==y)
+blah x y = f (g x y) (g x y)
  
index f619687..165a777 100644 (file)
@@ -1,8 +1,8 @@
 
-T6082-RULE.hs:5:11: Warning:
+T6082-RULE.hs:5:11: warning:
     Rule "foo1" may never fire because ‘foo1’ might inline first
-    Probable fix: add an INLINE[n] or NOINLINE[n] pragma on ‘foo1’
+    Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘foo1’
 
-T6082-RULE.hs:10:11: Warning:
+T6082-RULE.hs:10:11: warning:
     Rule "foo2" may never fire because ‘foo2’ might inline first
-    Probable fix: add an INLINE[n] or NOINLINE[n] pragma on ‘foo2’
+    Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘foo2’
index 1d777bd..2768fb5 100644 (file)
@@ -6,3 +6,14 @@ import GHC.Prim
 {-# RULES\r
   "int2Word#/word2Int#" forall x. int2Word# (word2Int# x) = x\r
   #-}\r
+\r
+{- We get a legitmiate\r
+\r
+   T7287.hs:7:3: warning:\r
+       Rule int2Word#/word2Int# may never fire because\r
+         rule "word2Int#" for ‘word2Int#’ might fire first\r
+       Probable fix: add phase [n] or [~n] to the competing rule\r
+\r
+because rule "word2Int#" is the constant folding rule that converts\r
+a sufficiently-narrow Word# literal to an Int#.  There is a similar\r
+one for int2Word#, so the whole lot is confluent. -}
\ No newline at end of file
index f1636bf..440fd05 100644 (file)
@@ -9,6 +9,7 @@ module ShouldCompile where
 
 {-# NOINLINE [1] foo #-}
 foo 1 = 2
+{-# NOINLINE [1] bar #-}
 bar 0 = 1
 
 foobar = 2