module CoreLint (
lintCoreBindings,
lintUnfolding,
- beginPass, endPass, endPassWithRules
+ showPass, endPass, endPassWithRules
) where
#include "HsVersions.h"
-import IO ( hPutStr, hPutStrLn, stdout )
+import IO ( hPutStr, hPutStrLn, stdout )
-import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
import CoreSyn
import Rules ( RuleBase, pprRuleBase )
import CoreFVs ( idFreeVars, mustHaveLocalBinding )
import Subst ( mkTyVarSubst, substTy )
import Name ( getSrcLoc )
import PprCore
-import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message,
+import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
ErrMsg, addErrLocHdrLine, pprBagOfErrors,
WarnMsg, pprBagOfWarnings)
-import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
+import SrcLoc ( SrcLoc, noSrcLoc )
import Type ( Type, tyVarsOfType,
splitFunTy_maybe, mkTyVarTy,
- splitForAllTy_maybe, splitTyConApp_maybe,
+ splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
isUnLiftedType, typeKind,
isUnboxedTupleType,
hasMoreBoxityInfo
)
-import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
+import TyCon ( isPrimTyCon )
import BasicTypes ( RecFlag(..), isNonRec )
+import CmdLineOpts
import Maybe
import Outputable
and do Core Lint when necessary.
\begin{code}
-beginPass :: String -> IO ()
-beginPass pass_name
- | opt_D_show_passes
- = hPutStrLn stdout ("*** " ++ pass_name)
- | otherwise
- = return ()
-
-
-endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
-endPass pass_name dump_flag binds
+endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+endPass dflags pass_name dump_flag binds
= do
- (binds, _) <- endPassWithRules pass_name dump_flag binds Nothing
+ (binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing
return binds
-endPassWithRules :: String -> Bool -> [CoreBind] -> Maybe RuleBase
+endPassWithRules :: DynFlags -> String -> DynFlag -> [CoreBind]
+ -> Maybe RuleBase
-> IO ([CoreBind], Maybe RuleBase)
-endPassWithRules pass_name dump_flag binds rules
+endPassWithRules dflags pass_name dump_flag binds rules
= do
-- ToDo: force the rules?
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
- if opt_D_show_passes then
+ if verbosity dflags >= 2 then
hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
else
return ()
-- Report verbosely, if required
- dumpIfSet dump_flag pass_name
+ dumpIfSet_core dflags dump_flag pass_name
(pprCoreBindings binds $$ case rules of
Nothing -> empty
Just rb -> pprRuleBase rb)
-- Type check
- lintCoreBindings pass_name binds
+ lintCoreBindings dflags pass_name binds
-- ToDo: lint the rules
return (binds, rules)
-- may well be happening...);
\begin{code}
-lintCoreBindings :: String -> [CoreBind] -> IO ()
+lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
-lintCoreBindings whoDunnit binds
- | not opt_DoCoreLinting
+lintCoreBindings dflags whoDunnit binds
+ | not (dopt Opt_DoCoreLinting dflags)
= return ()
-lintCoreBindings whoDunnit binds
+lintCoreBindings dflags whoDunnit binds
= case (initL (lint_binds binds)) of
(Nothing, Nothing) -> done_lint
returnL ()
lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
- done_lint = doIfSet opt_D_show_passes
+ done_lint = doIfSet (verbosity dflags >= 2)
(hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
warn warnings
= vcat [
(it is very painful to catch errors otherwise):
\begin{code}
-lintUnfolding :: SrcLoc
+lintUnfolding :: DynFlags
+ -> SrcLoc
-> [Var] -- Treat these as in scope
-> CoreExpr
-> (Maybe Message, Maybe Message) -- (Nothing,_) => OK
-lintUnfolding locn vars expr
- | not opt_DoCoreLinting
+lintUnfolding dflags locn vars expr
+ | not (dopt Opt_DoCoreLinting dflags)
= (Nothing, Nothing)
| otherwise
= initL (addLoc (ImportedUnfolding locn) $
- addInScopeVars vars $
- lintCoreExpr expr)
+ addInScopeVars vars $
+ lintCoreExpr expr)
\end{code}
%************************************************************************
-- Scrutinee type must be a tycon applicn; checked by caller
-- This code is remarkably compact considering what it does!
-- NB: args must be in scope here so that the lintCoreArgs line works.
- case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
+ case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
| otherwise = cxt1
- mk_msg msg
- | isNoSrcLoc loc = (loc, hang context 4 msg)
- | otherwise = addErrLocHdrLine loc context msg
+ mk_msg msg = addErrLocHdrLine loc context msg
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m loc scope errs warns