Commit 07d604fa authored by Peter Wortmann's avatar Peter Wortmann Committed by Austin Seipp

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)
parent 3b893f38
......@@ -161,6 +161,7 @@ data OneShotInfo
| ProbOneShot -- ^ The lambda is probably applied at most once
-- See Note [Computing one-shot info, and ProbOneShot] in OccurAnl
| OneShotLam -- ^ The lambda is applied at most once.
deriving (Eq)
-- | It is always safe to assume that an 'Id' has no lambda-bound variable information
noOneShotInfo :: OneShotInfo
......@@ -632,6 +633,8 @@ data OccInfo
| IAmALoopBreaker -- Note [LoopBreaker OccInfo]
!RulesOnly
deriving (Eq)
type RulesOnly = Bool
{-
......
......@@ -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)
......@@ -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]
......
......@@ -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
{-
************************************************************************
......
......@@ -313,6 +313,7 @@ data GeneralFlag
| Opt_DoStgLinting
| Opt_DoCmmLinting
| Opt_DoAsmLinting
| Opt_DoAnnotationLinting
| Opt_NoLlvmMangler -- hidden flag
| Opt_WarnIsError -- -Werror; makes warnings fatal
......@@ -2499,6 +2500,8 @@ dynamic_flags = [
(NoArg (setGeneralFlag Opt_DoCmmLinting))
, defGhcFlag "dasm-lint"
(NoArg (setGeneralFlag Opt_DoAsmLinting))
, defGhcFlag "dannot-lint"
(NoArg (setGeneralFlag Opt_DoAnnotationLinting))
, defGhcFlag "dshow-passes" (NoArg (do forceRecompile
setVerbosity $ Just 2))
, defGhcFlag "dfaststring-stats"
......
......@@ -22,7 +22,8 @@ import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo
import CoreUtils ( coreBindsSize, coreBindsStats, exprSize,
mkTicks, stripTicksTop )
import CoreLint ( showPass, endPass, lintPassResult, dumpPassResult )
import CoreLint ( showPass, endPass, lintPassResult, dumpPassResult,
lintAnnots )
import Simplify ( simplTopBinds, simplExpr )
import SimplUtils ( simplEnvForGHCi, activeRule )
import SimplEnv
......@@ -343,7 +344,7 @@ runCorePasses passes guts
do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
do_pass guts pass
= do { showPass pass
; guts' <- doCorePass pass guts
; guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
; endPass pass (mg_binds guts') (mg_rules guts')
; return guts' }
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment