Commit dfa8ef03 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent e5255476
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
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