diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2013-09-03 09:10:26 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2013-09-03 09:20:35 +0100 |
commit | dfa8ef031c83998c163bb94fb84ff8e02ef86cf8 (patch) | |
tree | 419031d9a9985af5319a21f1cb0e7ef09a9c9249 | |
parent | e52554768ad28bd0c191826100786b1aee3295dc (diff) | |
download | haskell-dfa8ef031c83998c163bb94fb84ff8e02ef86cf8.tar.gz |
Improve Linting in GHCi (fixes Trac #8215)
The original problem was that we weren't bringing varaibles bound in the
interactive context into scope before Linting the result of a top-level
declaration in GHCi. (We were doing this for expressions.)
Moreover I found that we weren't Linting the result of desugaring
a GHCi expression, which we really should be doing.
It took me a bit of time to unravel all this, and I did some refactoring
to make it easier next time.
* CoreMonad contains the Lint wrappers that get the right
environments into place. It always had endPass and lintPassResult
(which Lints bindings), but now it has lintInteractiveExpr.
* Both use a common function CoreMonad.interactiveInScope to find
those in-scope variables.
Quite a bit of knock-on effects from this, but nothing exciting.
-rw-r--r-- | compiler/coreSyn/CoreLint.lhs | 23 | ||||
-rw-r--r-- | compiler/coreSyn/CorePrep.lhs | 2 | ||||
-rw-r--r-- | compiler/deSugar/Desugar.lhs | 29 | ||||
-rw-r--r-- | compiler/main/HscMain.hs | 48 | ||||
-rw-r--r-- | compiler/main/TidyPgm.lhs | 2 | ||||
-rw-r--r-- | compiler/simplCore/CoreMonad.lhs | 84 | ||||
-rw-r--r-- | compiler/simplCore/SimplCore.lhs | 15 |
7 files changed, 131 insertions, 72 deletions
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 68aaea5b5c..1913e3ab93 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -16,7 +16,7 @@ A ``lint'' pass to check for Core correctness {-# OPTIONS_GHC -fprof-auto #-} -module CoreLint ( lintCoreBindings, lintUnfolding ) where +module CoreLint ( lintCoreBindings, lintUnfolding, lintExpr ) where #include "HsVersions.h" @@ -120,14 +120,15 @@ find an occurence of an Id, we fetch it from the in-scope set. \begin{code} -lintCoreBindings :: CoreProgram -> (Bag MsgDoc, Bag MsgDoc) +lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) -- Returns (warnings, errors) -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lintCoreBindings binds +lintCoreBindings local_in_scope binds = initL $ - addLoc TopLevelBindings $ - addInScopeVars binders $ + addLoc TopLevelBindings $ + addInScopeVars local_in_scope $ + addInScopeVars binders $ -- Put all the top-level binders in scope at the start -- This is because transformation rules can bring something -- into use 'unexpectedly' @@ -178,6 +179,18 @@ lintUnfolding locn vars expr (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $ addInScopeVars vars $ lintCoreExpr expr) + +lintExpr :: [Var] -- Treat these as in scope + -> CoreExpr + -> Maybe MsgDoc -- Nothing => OK + +lintExpr vars expr + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + (_warns, errs) = initL (addLoc TopLevelBindings $ + addInScopeVars vars $ + lintCoreExpr expr) \end{code} %************************************************************************ diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index d87fdfc197..1a21253f39 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -172,7 +172,7 @@ corePrepPgm dflags hsc_env binds data_tycons = do floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds return (deFloatTop (floats1 `appendFloats` floats2)) - endPass dflags CorePrep binds_out [] + endPass hsc_env CorePrep binds_out [] return binds_out corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index b65304a118..20a8a57299 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -143,14 +143,14 @@ deSugar hsc_env #ifdef DEBUG -- Debug only as pre-simple-optimisation program may be really big - ; endPass dflags CoreDesugar final_pgm rules_for_imps + ; endPass hsc_env CoreDesugar final_pgm rules_for_imps #endif ; (ds_binds, ds_rules_for_imps, ds_vects) <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0 -- The simpleOptPgm gets rid of type -- bindings plus any stupid dead code - ; endPass dflags CoreDesugarOpt ds_binds ds_rules_for_imps + ; endPass hsc_env CoreDesugarOpt ds_binds ds_rules_for_imps ; let used_names = mkUsedNames tcg_env ; deps <- mkDependencies tcg_env @@ -226,22 +226,23 @@ deSugarExpr :: HscEnv -> IO (Messages, Maybe CoreExpr) -- Prints its own errors; returns Nothing if error occurred -deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do - let dflags = hsc_dflags hsc_env - showPass dflags "Desugar" +deSugarExpr hsc_env this_mod rdr_env type_env tc_expr + = do { let dflags = hsc_dflags hsc_env + ; showPass dflags "Desugar" - -- Do desugaring - (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $ - dsLExpr tc_expr + -- Do desugaring + ; (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $ + dsLExpr tc_expr - case mb_core_expr of - Nothing -> return (msgs, Nothing) - Just expr -> do + ; case mb_core_expr of { + Nothing -> return (msgs, Nothing) ; + Just expr -> - -- Dump output - dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr) + + -- Dump output + do { dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr) - return (msgs, Just expr) + ; return (msgs, Just expr) } } } \end{code} %************************************************************************ diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index e884fe5bcf..ad1b7c503a 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -81,9 +81,8 @@ import CoreTidy ( tidyExpr ) import Type ( Type ) import PrelNames import {- Kind parts of -} Type ( Kind ) -import CoreLint ( lintUnfolding ) +import CoreMonad ( lintInteractiveExpr ) import DsMeta ( templateHaskellNames ) -import VarSet import VarEnv ( emptyTidyEnv ) import Panic @@ -1385,12 +1384,12 @@ hscStmtWithLocation hsc_env0 stmt source linenumber = -- Desugar it ds_expr <- ioMsgMaybe $ - deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr + deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr + liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr) handleWarnings -- Then code-gen, and link it - hsc_env <- getHscEnv - hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr + hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr let hval_io = unsafeCoerce# hval :: IO [HValue] return $ Just (ids, hval_io, fix_env) @@ -1618,37 +1617,28 @@ hscCompileCoreExpr hsc_env srcspan ds_expr = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler") -- Otherwise you get a seg-fault when you run it - | otherwise = do - let dflags = hsc_dflags hsc_env - let lint_on = gopt Opt_DoCoreLinting dflags + | otherwise + = do { let dflags = hsc_dflags hsc_env - {- Simplify it -} - simpl_expr <- simplifyExpr dflags ds_expr + {- Simplify it -} + ; simpl_expr <- simplifyExpr dflags ds_expr - {- Tidy it (temporary, until coreSat does cloning) -} - let tidy_expr = tidyExpr emptyTidyEnv simpl_expr + {- Tidy it (temporary, until coreSat does cloning) -} + ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr - {- Prepare for codegen -} - prepd_expr <- corePrepExpr dflags hsc_env tidy_expr + {- Prepare for codegen -} + ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr - {- Lint if necessary -} - -- ToDo: improve SrcLoc - when lint_on $ - let ictxt = hsc_IC hsc_env - te = mkTypeEnvWithImplicits (ic_tythings ictxt ++ map AnId (ic_sys_vars ictxt)) - tyvars = varSetElems $ tyThingsTyVars $ typeEnvElts $ te - vars = typeEnvIds te - in case lintUnfolding noSrcLoc (tyvars ++ vars) prepd_expr of - Just err -> pprPanic "hscCompileCoreExpr" err - Nothing -> return () + {- Lint if necessary -} + ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr - {- Convert to BCOs -} - bcos <- coreExprToBCOs dflags iNTERACTIVE prepd_expr + {- Convert to BCOs -} + ; bcos <- coreExprToBCOs dflags iNTERACTIVE prepd_expr - {- link it -} - hval <- linkExpr hsc_env srcspan bcos + {- link it -} + ; hval <- linkExpr hsc_env srcspan bcos - return hval + ; return hval } #endif diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 7b3695dbed..5d0cc42717 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -363,7 +363,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } - ; endPass dflags CoreTidy all_tidy_binds tidy_rules + ; endPass hsc_env CoreTidy all_tidy_binds tidy_rules -- If the endPass didn't print the rules, but ddump-rules is -- on, print now diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 31547e14a2..0af8201170 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -50,7 +50,8 @@ module CoreMonad ( getAnnotations, getFirstAnnotations, -- ** Debug output - showPass, endPass, dumpPassResult, lintPassResult, dumpIfSet, + showPass, endPass, dumpPassResult, lintPassResult, + lintInteractiveExpr, dumpIfSet, -- ** Screen output putMsg, putMsgS, errorMsg, errorMsgS, @@ -70,7 +71,7 @@ import Name( Name ) import CoreSyn import PprCore import CoreUtils -import CoreLint ( lintCoreBindings ) +import CoreLint ( lintCoreBindings, lintExpr ) import HscTypes import Module import DynFlags @@ -78,12 +79,13 @@ import StaticFlags import Rules ( RuleBase ) import BasicTypes ( CompilerPhase(..) ) import Annotations -import Id ( Id ) import IOEnv hiding ( liftIO, failM, failWithM ) import qualified IOEnv ( liftIO ) import TcEnv ( tcLookupGlobal ) import TcRnMonad ( initTcForLookup ) +import Var +import VarSet import Outputable import FastString @@ -136,11 +138,12 @@ stuff before and after core passes, and do Core Lint when necessary. showPass :: DynFlags -> CoreToDo -> IO () showPass dflags pass = Err.showPass dflags (showPpr dflags pass) -endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () -endPass dflags pass binds rules +endPass :: HscEnv -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () +endPass hsc_env pass binds rules = do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules - ; lintPassResult dflags pass binds } + ; lintPassResult hsc_env pass binds } where + dflags = hsc_dflags hsc_env mb_flag = case coreDumpFlag pass of Just flag | dopt flag dflags -> Just flag | dopt Opt_D_verbose_core2core dflags -> Just flag @@ -178,12 +181,16 @@ dumpPassResult dflags mb_flag hdr extra_info binds rules , ptext (sLit "------ Local rules for imported ids --------") , pprRules rules ] -lintPassResult :: DynFlags -> CoreToDo -> CoreProgram -> IO () -lintPassResult dflags pass binds - = when (gopt Opt_DoCoreLinting dflags) $ - do { let (warns, errs) = lintCoreBindings binds +lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO () +lintPassResult hsc_env pass binds + | not (gopt Opt_DoCoreLinting dflags) + = return () + | otherwise + = do { let (warns, errs) = lintCoreBindings (interactiveInScope hsc_env) binds ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass) ; displayLintResults dflags pass warns errs binds } + where + dflags = hsc_dflags hsc_env displayLintResults :: DynFlags -> CoreToDo -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram @@ -191,7 +198,7 @@ displayLintResults :: DynFlags -> CoreToDo displayLintResults dflags pass warns errs binds | not (isEmptyBag errs) = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle - (vcat [ banner "errors", Err.pprMessageBag errs + (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs , ptext (sLit "*** Offending Program ***") , pprCoreBindings binds , ptext (sLit "*** End of Offense ***") ]) @@ -206,19 +213,66 @@ displayLintResults dflags pass warns errs binds , not opt_NoDebugOutput , showLintWarnings pass = log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle - (banner "warnings" $$ Err.pprMessageBag warns) + (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns) | otherwise = return () where - banner string = ptext (sLit "*** Core Lint") <+> text string - <+> ptext (sLit ": in result of") <+> ppr pass - <+> ptext (sLit "***") + +lint_banner :: String -> SDoc -> SDoc +lint_banner string pass = ptext (sLit "*** Core Lint") <+> text string + <+> ptext (sLit ": in result of") <+> pass + <+> ptext (sLit "***") showLintWarnings :: CoreToDo -> Bool -- Disable Lint warnings on the first simplifier pass, because -- there may be some INLINE knots still tied, which is tiresomely noisy showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False showLintWarnings _ = True + +lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO () +lintInteractiveExpr what hsc_env expr + | not (gopt Opt_DoCoreLinting dflags) + = return () + | Just err <- lintExpr (interactiveInScope hsc_env) expr + = do { display_lint_err err + ; Err.ghcExit dflags 1 } + | otherwise + = return () + where + dflags = hsc_dflags hsc_env + + display_lint_err err + = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle + (vcat [ lint_banner "errors" (text what) + , err + , ptext (sLit "*** Offending Program ***") + , pprCoreExpr expr + , ptext (sLit "*** End of Offense ***") ]) + ; Err.ghcExit dflags 1 } + +interactiveInScope :: HscEnv -> [Var] +-- In GHCi we may lint expressions, or bindings arising from 'deriving' +-- clauses, that mention variables bound in the interactive context. +-- These are Local things (see Note [Interactively-bound Ids in GHCi] in TcRnDriver). +-- So we have to tell Lint about them, lest it reports them as out of scope. +-- +-- We do this by find local-named things that may appear free in interactive +-- context. This function is pretty revolting and quite possibly not quite right. +-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty +-- so this is a (cheap) no-op. +-- +-- See Trac #8215 for an example +interactiveInScope hsc_env + = tyvars ++ vars + where + ictxt = hsc_IC hsc_env + te = mkTypeEnvWithImplicits (ic_tythings ictxt ++ map AnId (ic_sys_vars ictxt)) + vars = typeEnvIds te + tyvars = varSetElems $ tyThingsTyVars $ typeEnvElts $ te + -- Why the type variables? How can the top level envt have free tyvars? + -- I think it's becuase of the GHCi debugger, which can bind variables + -- f :: [t] -> [t] + -- where t is a RuntimeUnk (see TcType) \end{code} diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index a3101f715e..4b07d3bb1c 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -370,10 +370,11 @@ runCorePasses passes guts do_pass guts CoreDoNothing = return guts do_pass guts (CoreDoPasses ps) = runCorePasses ps guts do_pass guts pass - = do { dflags <- getDynFlags + = do { hsc_env <- getHscEnv + ; let dflags = hsc_dflags hsc_env ; liftIO $ showPass dflags pass ; guts' <- doCorePass dflags pass guts - ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts') + ; liftIO $ endPass hsc_env pass (mg_binds guts') (mg_rules guts') ; return guts' } doCorePass :: DynFlags -> CoreToDo -> ModGuts -> CoreM ModGuts @@ -676,7 +677,8 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - end_iteration dflags pass iteration_no counts1 binds2 rules1 ; + dump_end_iteration dflags iteration_no counts1 binds2 rules1 ; + lintPassResult hsc_env pass binds2 ; -- Loop do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 @@ -693,11 +695,10 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" ------------------- -end_iteration :: DynFlags -> CoreToDo -> Int +dump_end_iteration :: DynFlags -> Int -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -end_iteration dflags pass iteration_no counts binds rules - = do { dumpPassResult dflags mb_flag hdr pp_counts binds rules - ; lintPassResult dflags pass binds } +dump_end_iteration dflags iteration_no counts binds rules + = dumpPassResult dflags mb_flag hdr pp_counts binds rules where mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_phases | otherwise = Nothing |