diff options
| -rw-r--r-- | compiler/basicTypes/BasicTypes.hs | 3 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreLint.hs | 64 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreSyn.hs | 1 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreUtils.hs | 155 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 3 | ||||
| -rw-r--r-- | compiler/simplCore/SimplCore.hs | 5 |
6 files changed, 224 insertions, 7 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index d2207d48f4..99e6de6454 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -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 {- 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 {- ************************************************************************ diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 844fa97e35..39bda21d71 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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" diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 746e0d0724..8acea27df4 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -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' } |