+
%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-\section[CoreLint]{A ``lint'' pass to check for Core correctness}
+
+A ``lint'' pass to check for Core correctness
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module CoreLint (
lintCoreBindings,
lintUnfolding,
- showPass, endPass
+ showPass, endPass, endIteration
) where
#include "HsVersions.h"
+import NewDemand
import CoreSyn
-import CoreFVs ( idFreeVars )
-import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize )
+import CoreFVs
+import CoreUtils
import Bag
-import Literal ( literalType )
-import DataCon ( dataConRepType, dataConTyCon, dataConWorkId )
-import TysWiredIn ( tupleCon )
-import Var ( Var, Id, TyVar, isCoVar, idType, tyVarKind,
- mustHaveLocalBinding, setTyVarKind, setIdType )
-import VarEnv ( lookupInScope )
+import Literal
+import DataCon
+import TysWiredIn
+import Var
+import VarEnv
import VarSet
-import Name ( getSrcLoc )
+import Name
+import Id
import PprCore
-import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
- mkLocMessage, debugTraceMsg )
-import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan )
-import Type ( Type, tyVarsOfType, coreEqType,
- splitFunTy_maybe,
- splitForAllTy_maybe, splitTyConApp_maybe,
- isUnLiftedType, typeKind, mkForAllTy, mkFunTy,
- isUnboxedTupleType, isSubKind,
- substTyWith, emptyTvSubst, extendTvInScope,
- TvSubst, substTy,
- extendTvSubst, substTyVarBndr, isInScope,
- getTvInScope )
-import Coercion ( coercionKind, coercionKindPredTy )
-import TyCon ( isPrimTyCon, isNewTyCon )
-import BasicTypes ( RecFlag(..), Boxity(..), isNonRec )
-import StaticFlags ( opt_PprStyle_Debug )
-import DynFlags ( DynFlags, DynFlag(..), dopt )
+import ErrUtils
+import SrcLoc
+import Type
+import Coercion
+import TyCon
+import BasicTypes
+import StaticFlags
+import ListSetOps
+import DynFlags
import Outputable
-
-#ifdef DEBUG
-import Util ( notNull )
-#endif
-
-import Maybe
-
+import Util
+import Data.Maybe
\end{code}
%************************************************************************
\begin{code}
endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
-endPass dflags pass_name dump_flag binds
+endPass = dumpAndLint dumpIfSet_core
+
+endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+endIteration = dumpAndLint dumpIfSet_dyn
+
+dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
+ -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+dumpAndLint dump dflags pass_name dump_flag binds
= do
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
(text " Result size =" <+> int (coreBindsSize binds))
-- Report verbosely, if required
- dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
+ dump dflags dump_flag pass_name (pprCoreBindings binds)
-- Type check
lintCoreBindings dflags pass_name binds
-- Put all the top-level binders in scope at the start
-- This is because transformation rules can bring something
-- into use 'unexpectedly'
- lint_binds binds = addInScopeVars (bindersOfBinds binds) $
+ lint_binds binds = addLoc TopLevelBindings $
+ addInScopeVars (bindersOfBinds binds) $
mapM lint_bind binds
- lint_bind (Rec prs) = mapM_ (lintSingleBinding Recursive) prs
- lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
+ lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
+ lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
display bad_news
= vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
Check a core binding, returning the list of variables bound.
\begin{code}
-lintSingleBinding rec_flag (binder,rhs)
+lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
= addLoc (RhsOf binder) $
-- Check the rhs
do { ty <- lintCoreExpr rhs
; checkL (not (isUnLiftedType binder_ty)
|| (isNonRec rec_flag && exprOkForSpeculation rhs))
(mkRhsPrimMsg binder rhs)
+ -- Check that if the binder is top-level or recursive, it's not demanded
+ ; checkL (not (isStrictId binder)
+ || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
+ (mkStrictMsg binder)
-- Check whether binder's specialisations contain any out-of-scope variables
- ; mapM_ (checkBndrIdInScope binder) bndr_vars }
+ ; mapM_ (checkBndrIdInScope binder) bndr_vars
+
+ -- Check whether arity and demand type are consistent (only if demand analysis
+ -- already happened)
+ ; checkL (case maybeDmdTy of
+ Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs
+ Nothing -> True)
+ (mkArityMsg binder) }
-- We should check the unfolding, if any, but this is tricky because
- -- the unfolding is a SimplifiableCoreExpr. Give up for now.
- where
- binder_ty = idType binder
- bndr_vars = varSetElems (idFreeVars binder)
+ -- the unfolding is a SimplifiableCoreExpr. Give up for now.
+ where
+ binder_ty = idType binder
+ maybeDmdTy = idNewStrictness_maybe binder
+ bndr_vars = varSetElems (idFreeVars binder)
lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
| otherwise = return ()
\end{code}
= lintCoreExpr expr
lintCoreExpr (Let (NonRec bndr rhs) body)
- = do { lintSingleBinding NonRecursive (bndr,rhs)
+ = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
; addLoc (BodyOfLetRec [bndr])
(lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
lintCoreExpr (Let (Rec pairs) body)
= lintAndScopeIds bndrs $ \_ ->
- do { mapM (lintSingleBinding Recursive) pairs
+ do { mapM (lintSingleBinding NotTopLevel Recursive) pairs
; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
where
bndrs = map fst pairs
else lintAndScopeId var
; scope $ \_ ->
do { -- Check the alternatives
- checkCaseAlts e scrut_ty alts
- ; mapM (lintCoreAlt scrut_ty alt_ty) alts
+ mapM (lintCoreAlt scrut_ty alt_ty) alts
+ ; checkCaseAlts e scrut_ty alts
; return alt_ty } }
where
pass_var f = f var
subtype of the required type, as one would expect.
\begin{code}
-lintCoreArgs :: Type -> [CoreArg] -> LintM Type
-lintCoreArg :: Type -> CoreArg -> LintM Type
+lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
+lintCoreArg :: OutType -> CoreArg -> LintM OutType
-- First argument has already had substitution applied to it
\end{code}
\begin{code}
-- Both args have had substitution applied
+lintTyApp :: OutType -> OutType -> LintM OutType
lintTyApp ty arg_ty
= case splitForAllTy_maybe ty of
Nothing -> addErrL (mkTyAppMsg ty arg_ty)
= addLoc (CaseAlt alt) $ do
{ -- First instantiate the universally quantified
-- type variables of the data constructor
- con_payload_ty <- lintCoreArgs (dataConRepType con) (map Type tycon_arg_tys)
+ -- We've already check
+ checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
+ ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
-- And now bring the new binders into scope
; lintBinders args $ \ args -> do
{ -- Check the pattern
-- 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
-
+ -- NB: args must be in scope here so that the lintCoreArgs
+ -- line works.
+ -- NB: relies on existential type args coming *after*
+ -- ordinary type args
; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
}
lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a
lintAndScopeId id linterF
= do { ty <- lintTy (idType id)
- ; let id' = setIdType id ty
+ ; let id' = Var.setIdType id ty
; addInScopeVars [id'] $ (linterF id')
}
| CasePat CoreAlt -- *Pattern* of the case alternative
| AnExpr CoreExpr -- Some expression
| ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
+ | TopLevelBindings
\end{code}
LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
addInScopeVars :: [Var] -> LintM a -> LintM a
-addInScopeVars vars m =
- LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
+addInScopeVars vars m
+ | null dups
+ = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
+ | otherwise
+ = addErrL (dupVars dups)
+ where
+ (_, dups) = removeDups compare vars
updateTvSubst :: TvSubst -> LintM a -> LintM a
updateTvSubst subst' m =
dumpLoc (ImportedUnfolding locn)
= (locn, brackets (ptext SLIT("in an imported unfolding")))
+dumpLoc TopLevelBindings
+ = (noSrcLoc, empty)
pp_binders :: [Var] -> SDoc
pp_binders bs = sep (punctuate comma (map pp_binder bs))
text "Scrutinee type:" <+> ppr scrut_ty,
hsep [ptext SLIT("Current TV subst"), ppr subst]]
-
mkNonDefltMsg e
= hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
mkNonIncreasingAltsMsg e
nonExhaustiveAltsMsg e
= hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
+mkBadConMsg :: TyCon -> DataCon -> Message
+mkBadConMsg tycon datacon
+ = vcat [
+ text "In a case alternative, data constructor isn't in scrutinee type:",
+ text "Scrutinee type constructor:" <+> ppr tycon,
+ text "Data con:" <+> ppr datacon
+ ]
+
mkBadPatMsg :: Type -> Type -> Message
mkBadPatMsg con_result_ty scrut_ty
= vcat [
hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
]
+mkStrictMsg :: Id -> Message
+mkStrictMsg binder
+ = vcat [hsep [ptext SLIT("Recursive or top-level binder has strict demand info:"),
+ ppr binder],
+ hsep [ptext SLIT("Binder's demand info:"), ppr (idNewDemandInfo binder)]
+ ]
+
+mkArityMsg :: Id -> Message
+mkArityMsg binder
+ = vcat [hsep [ptext SLIT("Demand type has "),
+ ppr (dmdTypeDepth dmd_ty),
+ ptext SLIT(" arguments, rhs has "),
+ ppr (idArity binder),
+ ptext SLIT("arguments, "),
+ ppr binder],
+ hsep [ptext SLIT("Binder's strictness signature:"), ppr dmd_ty]
+
+ ]
+ where (StrictSig dmd_ty) = idNewStrictness binder
+
mkUnboxedTupleMsg :: Id -> Message
mkUnboxedTupleMsg binder
= vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
]
+dupVars vars
+ = hang (ptext SLIT("Duplicate variables brought into scope"))
+ 2 (ppr vars)
+
mkStrangeTyMsg e
= ptext SLIT("Type where expression expected:") <+> ppr e
\end{code}
projects / ghc-hetmet.git / blobdiff