module CoreLint (
lintCoreBindings,
lintUnfolding,
- showPass, endPass, endPassWithRules
+ showPass, endPass
) where
#include "HsVersions.h"
import IO ( hPutStr, hPutStrLn, stdout )
import CoreSyn
-import Rules ( RuleBase, pprRuleBase )
import CoreFVs ( idFreeVars )
import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
import DataCon ( dataConRepType )
import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
import VarSet
-import Subst ( mkTyVarSubst, substTy )
+import Subst ( substTyWith )
import Name ( getSrcLoc )
import PprCore
import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
import BasicTypes ( RecFlag(..), isNonRec )
import CmdLineOpts
import Maybe
+import Util ( notNull )
import Outputable
infixr 9 `thenL`, `seqL`
%************************************************************************
%* *
-\subsection{Start and end pass}
+\subsection{End pass}
%* *
%************************************************************************
-@beginPass@ and @endPass@ don't really belong here, but it makes a convenient
+@showPass@ and @endPass@ don't really belong here, but it makes a convenient
place for them. They print out stuff before and after core passes,
and do Core Lint when necessary.
\begin{code}
endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
endPass dflags pass_name dump_flag binds
- = do
- (binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing
- return binds
-
-endPassWithRules :: DynFlags -> String -> DynFlag -> [CoreBind]
- -> Maybe RuleBase
- -> IO ([CoreBind], Maybe RuleBase)
-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 verbosity dflags >= 2 then
return ()
-- Report verbosely, if required
- dumpIfSet_core dflags dump_flag pass_name
- (pprCoreBindings binds $$ case rules of
- Nothing -> empty
- Just rb -> pprRuleBase rb)
+ dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
-- Type check
lintCoreBindings dflags pass_name binds
- -- ToDo: lint the rules
- return (binds, rules)
+ return binds
\end{code}
-- error :: forall a:*. String -> a
-- and then apply it to both boxed and unboxed types.
then
- returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
+ returnL (substTyWith [tyvar] [arg_ty] body)
else
addErrL (mkKindErrMsg tyvar arg_ty)
-- 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.
+ -- NB: relies on existential type args coming *after* ordinary type args
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 ->
addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
-- errors or warnings, actually... they're the same type.
addErr errs_so_far msg locs
- = ASSERT( not (null locs) )
+ = ASSERT( notNull locs )
errs_so_far `snocBag` mk_msg msg
where
(loc, cxt1) = dumpLoc (head locs)