#include "HsVersions.h"
-import IO ( hPutStr, stderr )
+import IO ( hPutStr, hPutStrLn, stderr )
-import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting )
+import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
import CoreSyn
-import CoreUtils ( idFreeVars )
+import CoreFVs ( idFreeVars )
+import CoreUtils ( exprOkForSpeculation )
import Bag
import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt )
import Id ( isConstantId, idMustBeINLINEd )
-import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar )
+import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar, isId )
import VarSet
-import VarEnv ( mkVarEnv )
+import Subst ( mkTyVarSubst, substTy )
import Name ( isLocallyDefined, getSrcLoc )
import PprCore
import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message,
import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
import Type ( Type, Kind, tyVarsOfType,
- splitFunTy_maybe, mkPiType, mkTyVarTy,
+ splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
splitForAllTy_maybe, splitTyConApp_maybe,
- isUnLiftedType, typeKind, substTy,
+ isUnLiftedType, typeKind,
splitAlgTyConApp_maybe,
isUnboxedTupleType,
hasMoreBoxityInfo
)
import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
+import BasicTypes ( RecFlag(..), isNonRec )
import Outputable
infixr 9 `thenL`, `seqL`
beginPass :: String -> IO ()
beginPass pass_name
| opt_D_show_passes
- = hPutStr stderr ("*** " ++ pass_name ++ "\n")
+ = hPutStrLn stderr ("*** " ++ pass_name)
| otherwise
= return ()
endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
endPass pass_name dump_flag binds
= do
+ -- Report result size if required
+ -- This has the side effect of forcing the intermediate to be evaluated
+ if opt_D_show_passes then
+ hPutStrLn stderr (" Result size = " ++ show (coreBindsSize binds))
+ else
+ return ()
+
-- Report verbosely, if required
dumpIfSet dump_flag pass_name
(pprCoreBindings binds)
Just bad_news -> printDump (display bad_news) >>
ghcExit 1
where
- lint_binds [] = returnL ()
- lint_binds (bind:binds)
- = lintCoreBinding bind `thenL` \binders ->
- addInScopeVars binders (lint_binds 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) $
+ mapL lint_bind binds
+
+ lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL`
+ returnL ()
+ lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
display bad_news
= vcat [
(it is very painful to catch errors otherwise):
\begin{code}
-lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
-
-lintUnfolding locn expr
- = case
- initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
- of
- Nothing -> Just expr
- Just msg ->
- pprTrace "WARNING: Discarded bad unfolding from interface:\n"
- (vcat [msg,
- ptext SLIT("*** Bad unfolding ***"),
- ppr expr,
- ptext SLIT("*** End unfolding ***")])
- Nothing
+lintUnfolding :: SrcLoc
+ -> [IdOrTyVar] -- Treat these as in scope
+ -> CoreExpr
+ -> Maybe Message -- Nothing => OK
+
+lintUnfolding locn vars expr
+ | not opt_DoCoreLinting
+ = Nothing
+
+ | otherwise
+ = initL (addLoc (ImportedUnfolding locn) $
+ addInScopeVars vars $
+ lintCoreExpr expr)
\end{code}
%************************************************************************
Check a core binding, returning the list of variables bound.
\begin{code}
-lintCoreBinding :: CoreBind -> LintM [Id]
-
-lintCoreBinding (NonRec binder rhs)
- = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
-
-lintCoreBinding (Rec pairs)
- = addInScopeVars binders (
- mapL lintSingleBinding pairs `seqL` returnL binders
- )
- where
- binders = map fst pairs
-
-lintSingleBinding (binder,rhs)
+lintSingleBinding rec_flag (binder,rhs)
= addLoc (RhsOf binder) $
-- Check the rhs
checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
-- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
- checkL (not (isUnLiftedType binder_ty))
+ checkL (not (isUnLiftedType binder_ty) || (isNonRec rec_flag && exprOkForSpeculation rhs))
(mkRhsPrimMsg binder rhs) `seqL`
-- Check whether binder's specialisations contain any out-of-scope variables
= lintCoreExpr expr `thenL` \ expr_ty ->
lintTy to_ty `seqL`
lintTy from_ty `seqL`
- checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
+ checkTys from_ty (unUsgTy expr_ty) (mkCoerceErr from_ty expr_ty) `seqL`
returnL to_ty
lintCoreExpr (Note other_note expr)
= lintCoreExpr expr
-lintCoreExpr (Let binds body)
- = lintCoreBinding binds `thenL` \binders ->
- if (null binders) then
- lintCoreExpr body -- Can't add a new source location
- else
- addLoc (BodyOfLetRec binders)
- (addInScopeVars binders (lintCoreExpr body))
+lintCoreExpr (Let (NonRec bndr rhs) body)
+ = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
+ addLoc (BodyOfLetRec [bndr])
+ (addInScopeVars [bndr] (lintCoreExpr body))
+
+lintCoreExpr (Let (Rec pairs) body)
+ = addInScopeVars bndrs $
+ mapL (lintSingleBinding Recursive) pairs `seqL`
+ addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
+ where
+ bndrs = map fst pairs
lintCoreExpr e@(Con con args)
= addLoc (AnExpr e) $
-- error :: forall a:*. String -> a
-- and then apply it to both boxed and unboxed types.
then
- returnL (substTy (mkVarEnv [(tyvar,arg_ty)]) body)
+ returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
else
addErrL (mkKindErrMsg tyvar arg_ty)
if isPrimTyCon tycon then
checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
else
+{- No longer needed
#ifdef DEBUG
-- Algebraic cases are not necessarily exhaustive, because
-- the simplifer correctly eliminates case that can't
nopL
else
#endif
+-}
nopL }
hasDefault [] = False
= ASSERT (not (null locs))
errs_so_far `snocBag` mk_msg msg
where
- (loc, pref) = dumpLoc (head locs)
-
+ (loc, cxt1) = dumpLoc (head locs)
+ cxts = [snd (dumpLoc loc) | loc <- locs]
+ context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
+ | otherwise = cxt1
+
mk_msg msg
- | isNoSrcLoc loc = (loc, hang pref 4 msg)
- | otherwise = addErrLocHdrLine loc pref msg
+ | isNoSrcLoc loc = (loc, hang context 4 msg)
+ | otherwise = addErrLocHdrLine loc context msg
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m loc scope errs
ppr binder
checkInScope :: SDoc -> IdOrTyVar -> LintM ()
-checkInScope loc_msg id loc scope errs
- | isLocallyDefined id
- && not (id `elemVarSet` scope)
- && not (idMustBeINLINEd id) -- Constructors and dict selectors
- -- don't have bindings,
- -- just MustInline prags
- = (Nothing, addErr errs (hsep [ppr id, loc_msg]) loc)
+checkInScope loc_msg var loc scope errs
+ | isLocallyDefined var
+ && not (var `elemVarSet` scope)
+ && not (isId var && idMustBeINLINEd var) -- Constructors and dict selectors
+ -- don't have bindings,
+ -- just MustInline prags
+ = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
| otherwise
= (Nothing,errs)
projects / ghc-hetmet.git / blobdiff