Annotation linting

This adds a way by which we can make sure that the Core passes treat
annotations right: We run them twice and compare the results.

The main problem here is that Core equivalence is awkward: We do not
want the comparison to care about the order of, say, top-level or
recursive bindings. This is important even if GHC generally generates
the bindings in the right order - after all, if something goes wrong
we don't want linting to dump out the whole program as the offense.

So instead we do some heuristic matching - first greedily match
everything that's easy, then match the rest by label order. This
should work as long as GHC generates the labels in roughly the same
order for both pass runs.  In practice it seems to work alright.

We also check that IdInfos match, as this might cause hard-to-spot
bugs down the line (I had at least one bug because unfolding guidance
didn't match!). We especially check unfoldings up until the point
where it might get us into an infinite loop.

(From Phabricator D169)

3 files changed, 215 insertions, 5 deletions

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 6befb80840..7b57ba2d9a 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -12,6 +12,7 @@ A ``lint'' pass to check for Core correctness
 module CoreLint ( 
     lintCoreBindings, lintUnfolding, 
     lintPassResult, lintInteractiveExpr, lintExpr,
+    lintAnnots,
 
     -- ** Debug output
     CoreLint.showPass, showPassIO, endPass, endPassIO, 
@@ -54,6 +55,7 @@ import FastString
 import Util
 import InstEnv     ( instanceDFunId )
 import OptCoercion ( checkAxInstCo )
+import UniqSupply
 
 import HscTypes
 import DynFlags
@@ -1688,3 +1690,65 @@ dupExtVars :: [[Name]] -> MsgDoc
 dupExtVars vars
   = hang (ptext (sLit "Duplicate top-level variables with the same qualified name"))
        2 (ppr vars)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Annotation Linting}
+*                                                                      *
+************************************************************************
+-}
+
+-- | This checks whether a pass correctly looks through debug
+-- annotations (@SourceNote@). This works a bit different from other
+-- consistency checks: We check this by running the given task twice,
+-- noting all differences between the results.
+lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+lintAnnots pname pass guts = do
+  -- Run the pass as we normally would
+  dflags <- getDynFlags
+  when (gopt Opt_DoAnnotationLinting dflags) $
+    liftIO $ Err.showPass dflags "Annotation linting - first run"
+  nguts <- pass guts
+  -- If appropriate re-run it without debug annotations to make sure
+  -- that they made no difference.
+  when (gopt Opt_DoAnnotationLinting dflags) $ do
+    liftIO $ Err.showPass dflags "Annotation linting - second run"
+    nguts' <- withoutAnnots pass guts
+    -- Finally compare the resulting bindings
+    liftIO $ Err.showPass dflags "Annotation linting - comparison"
+    let binds = flattenBinds $ mg_binds nguts
+        binds' = flattenBinds $ mg_binds nguts'
+        (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'
+    when (not (null diffs)) $ CoreMonad.putMsg $ vcat
+      [ lint_banner "warning" pname
+      , text "Core changes with annotations:"
+      , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs
+      ]
+  -- Return actual new guts
+  return nguts
+
+-- | Run the given pass without annotations. This means that we both
+-- remove the @Opt_Debug@ flag from the environment as well as all
+-- annotations from incoming modules.
+withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+withoutAnnots pass guts = do
+  -- Remove debug flag from environment.
+  dflags <- getDynFlags
+  let removeFlag env = env{hsc_dflags = gopt_unset dflags Opt_Debug}
+      withoutFlag corem =
+        liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
+                                getUniqueSupplyM <*> getModule <*>
+                                getPrintUnqualified <*> pure corem
+  -- Nuke existing ticks in module.
+  -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
+  -- them in absence of @Opt_Debug@?
+  let nukeTicks = snd . stripTicks (not . tickishIsCode)
+      nukeAnnotsBind :: CoreBind -> CoreBind
+      nukeAnnotsBind bind = case bind of
+        Rec bs     -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs
+        NonRec b e -> NonRec b $ nukeTicks e
+      nukeAnnotsMod mg@ModGuts{mg_binds=binds}
+        = mg{mg_binds = map nukeAnnotsBind binds}
+  -- Perform pass with all changes applied
+  fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts)
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 1a1f8404cc..0e9d9a2b52 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -951,6 +951,7 @@ data UnfoldingGuidance
                           -- (where there are the right number of arguments.)
 
   | UnfNever        -- The RHS is big, so don't inline it
+  deriving (Eq)
 
 {-
 Note [Historical note: unfoldings for wrappers]
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index c5340b867b..cfc4c45737 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -34,6 +34,7 @@ module CoreUtils (
 
         -- * Equality
         cheapEqExpr, cheapEqExpr', eqExpr,
+        diffExpr, diffBinds,
 
         -- * Eta reduction
         tryEtaReduce,
@@ -75,6 +76,7 @@ import Util
 import Pair
 import Data.Function       ( on )
 import Data.List
+import Data.Ord            ( comparing )
 import Control.Applicative
 #if __GLASGOW_HASKELL__ < 709
 import Data.Traversable    ( traverse )
@@ -1462,7 +1464,7 @@ eqExpr in_scope e1 e2
     go env (Coercion co1) (Coercion co2) = coreEqCoercion2 env co1 co2
     go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 env co1 co2 && go env e1 e2
     go env (App f1 a1)   (App f2 a2)   = go env f1 f2 && go env a1 a2
-    go env (Tick n1 e1)  (Tick n2 e2)  = go_tickish env n1 n2 && go env e1 e2
+    go env (Tick n1 e1)  (Tick n2 e2)  = eqTickish env n1 n2 && go env e1 e2
 
     go env (Lam b1 e1)  (Lam b2 e2)
       =  eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination
@@ -1473,7 +1475,8 @@ eqExpr in_scope e1 e2
       && go (rnBndr2 env v1 v2) e1 e2
 
     go env (Let (Rec ps1) e1) (Let (Rec ps2) e2)
-      = all2 (go env') rs1 rs2 && go env' e1 e2
+      = length ps1 == length ps2
+      && all2 (go env') rs1 rs2 && go env' e1 e2
       where
         (bs1,rs1) = unzip ps1
         (bs2,rs2) = unzip ps2
@@ -1491,10 +1494,152 @@ eqExpr in_scope e1 e2
     go_alt env (c1, bs1, e1) (c2, bs2, e2)
       = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2
 
-    -----------
-    go_tickish env (Breakpoint lid lids) (Breakpoint rid rids)
+eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool
+eqTickish env (Breakpoint lid lids) (Breakpoint rid rids)
       = lid == rid  &&  map (rnOccL env) lids == map (rnOccR env) rids
-    go_tickish _ l r = l == r
+eqTickish _ l r = l == r
+
+-- | Finds differences between core expressions, modulo alpha and
+-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be
+-- checked for differences as well.
+diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
+diffExpr _   env (Var v1)   (Var v2)   | rnOccL env v1 == rnOccR env v2 = []
+diffExpr _   _   (Lit lit1) (Lit lit2) | lit1 == lit2                   = []
+diffExpr _   env (Type t1)  (Type t2)  | eqTypeX env t1 t2              = []
+diffExpr _   env (Coercion co1) (Coercion co2)
+                                       | coreEqCoercion2 env co1 co2    = []
+diffExpr top env (Cast e1 co1)  (Cast e2 co2)
+  | coreEqCoercion2 env co1 co2            = diffExpr top env e1 e2
+diffExpr top env (Tick n1 e1)   e2
+  | not (tickishIsCode n1)                 = diffExpr top env e1 e2
+diffExpr top env e1             (Tick n2 e2)
+  | not (tickishIsCode n2)                 = diffExpr top env e1 e2
+diffExpr top env (Tick n1 e1)   (Tick n2 e2)
+  | eqTickish env n1 n2                    = diffExpr top env e1 e2
+ -- The error message of failed pattern matches will contain
+ -- generated names, which are allowed to differ.
+diffExpr _   _   (App (App (Var absent) _) _)
+                 (App (App (Var absent2) _) _)
+  | isBottomingId absent && isBottomingId absent2 = []
+diffExpr top env (App f1 a1)    (App f2 a2)
+  = diffExpr top env f1 f2 ++ diffExpr top env a1 a2
+diffExpr top env (Lam b1 e1)  (Lam b2 e2)
+  | eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination
+  = diffExpr top (rnBndr2 env b1 b2) e1 e2
+diffExpr top env (Let bs1 e1) (Let bs2 e2)
+  = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2])
+    in ds ++ diffExpr top env' e1 e2
+diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
+  | length a1 == length a2 && not (null a1) || eqTypeX env t1 t2
+    -- See Note [Empty case alternatives] in TrieMap
+  = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2)
+  where env' = rnBndr2 env b1 b2
+        diffAlt (c1, bs1, e1) (c2, bs2, e2)
+          | c1 /= c2  = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2]
+          | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2
+diffExpr _  _ e1 e2
+  = [fsep [ppr e1, text "/=", ppr e2]]
+
+-- | Finds differences between core bindings, see @diffExpr@.
+--
+-- The main problem here is that while we expect the binds to have the
+-- same order in both lists, this is not guaranteed. To do this
+-- properly we'd either have to do some sort of unification or check
+-- all possible mappings, which would be seriously expensive. So
+-- instead we simply match single bindings as far as we can. This
+-- leaves us just with mutually recursive and/or mismatching bindings,
+-- which we then specuatively match by ordering them. It's by no means
+-- perfect, but gets the job done well enough.
+diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
+          -> ([SDoc], RnEnv2)
+diffBinds top env binds1 = go (length binds1) env binds1
+ where go _    env []     []
+          = ([], env)
+       go fuel env binds1 binds2
+          -- No binds left to compare? Bail out early.
+          | null binds1 || null binds2
+          = (warn env binds1 binds2, env)
+          -- Iterated over all binds without finding a match? Then
+          -- try speculatively matching binders by order.
+          | fuel == 0
+          = if not $ env `inRnEnvL` fst (head binds1)
+            then let env' = uncurry (rnBndrs2 env) $ unzip $
+                            zip (sort $ map fst binds1) (sort $ map fst binds2)
+                 in go (length binds1) env' binds1 binds2
+            -- If we have already tried that, give up
+            else (warn env binds1 binds2, env)
+       go fuel env ((bndr1,expr1):binds1) binds2
+          | let matchExpr (bndr,expr) =
+                  (not top || null (diffIdInfo env bndr bndr1)) &&
+                  null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr)
+          , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2
+          = go (length binds1) (rnBndr2 env bndr1 bndr2)
+                binds1 (binds2l ++ binds2r)
+          | otherwise -- No match, so push back (FIXME O(n^2))
+          = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2
+       go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough
+
+       -- We have tried everything, but couldn't find a good match. So
+       -- now we just return the comparison results when we pair up
+       -- the binds in a pseudo-random order.
+       warn env binds1 binds2 =
+         concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++
+         unmatched "unmatched left-hand:" (drop l binds1') ++
+         unmatched "unmatched right-hand:" (drop l binds2')
+        where binds1' = sortBy (comparing fst) binds1
+              binds2' = sortBy (comparing fst) binds2
+              l = min (length binds1') (length binds2')
+       unmatched _   [] = []
+       unmatched txt bs = [text txt $$ ppr (Rec bs)]
+       diffBind env (bndr1,expr1) (bndr2,expr2)
+         | ds@(_:_) <- diffExpr top env expr1 expr2
+         = locBind "in binding" bndr1 bndr2 ds
+         | otherwise
+         = diffIdInfo env bndr1 bndr2
+
+-- | Find differences in @IdInfo@. We will especially check whether
+-- the unfoldings match, if present (see @diffUnfold@).
+diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]
+diffIdInfo env bndr1 bndr2
+  | arityInfo info1 == arityInfo info2
+    && cafInfo info1 == cafInfo info2
+    && oneShotInfo info1 == oneShotInfo info2
+    && inlinePragInfo info1 == inlinePragInfo info2
+    && occInfo info1 == occInfo info2
+    && demandInfo info1 == demandInfo info2
+    && callArityInfo info1 == callArityInfo info2
+  = locBind "in unfolding of" bndr1 bndr2 $
+    diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2)
+  | otherwise
+  = locBind "in Id info of" bndr1 bndr2
+    [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]]
+  where info1 = idInfo bndr1; info2 = idInfo bndr2
+
+-- | Find differences in unfoldings. Note that we will not check for
+-- differences of @IdInfo@ in unfoldings, as this is generally
+-- redundant, and can lead to an exponential blow-up in complexity.
+diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]
+diffUnfold _   NoUnfolding    NoUnfolding                 = []
+diffUnfold _   (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = []
+diffUnfold env (DFunUnfolding bs1 c1 a1)
+               (DFunUnfolding bs2 c2 a2)
+  | c1 == c2 && length bs1 == length bs2
+  = concatMap (uncurry (diffExpr False env')) (zip a1 a2)
+  where env' = rnBndrs2 env bs1 bs2
+diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1)
+               (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2)
+  | v1 == v2 && cl1 == cl2
+    && wf1 == wf2 && x1 == x2 && g1 == g2
+  = diffExpr False env t1 t2
+diffUnfold _   uf1 uf2
+  = [fsep [ppr uf1, text "/=", ppr uf2]]
+
+-- | Add location information to diff messages
+locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]
+locBind loc b1 b2 diffs = map addLoc diffs
+  where addLoc d            = d $$ nest 2 (parens (text loc <+> bindLoc))
+        bindLoc | b1 == b2  = ppr b1
+                | otherwise = ppr b1 <> char '/' <> ppr b2
 
 {-
 ************************************************************************