#include "HsVersions.h"
-import IO ( hPutStr, stderr )
+import IO ( hPutStr, hPutStrLn, stderr, stdout )
import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
import CoreSyn
import CoreFVs ( idFreeVars )
-import CoreUtils ( exprOkForSpeculation )
+import CoreUtils ( exprOkForSpeculation, coreBindsSize )
import Bag
-import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt )
-import Id ( isConstantId, idMustBeINLINEd )
-import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar, isId )
+import Literal ( Literal, literalType )
+import DataCon ( DataCon, dataConRepType )
+import Id ( mayHaveNoBinding, isDeadBinder )
+import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId )
import VarSet
import Subst ( mkTyVarSubst, substTy )
import Name ( isLocallyDefined, getSrcLoc )
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,
splitAlgTyConApp_maybe,
isUnboxedTupleType,
hasMoreBoxityInfo
)
+import PprType ( {- instance Outputable Type -} )
import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
import BasicTypes ( RecFlag(..), isNonRec )
import Outputable
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 stdout (" Result size = " ++ show (coreBindsSize binds))
+ else
+ return ()
+
-- Report verbosely, if required
dumpIfSet dump_flag pass_name
(pprCoreBindings binds)
\begin{code}
lintUnfolding :: SrcLoc
- -> [IdOrTyVar] -- Treat these as in scope
+ -> [Var] -- Treat these as in scope
-> CoreExpr
-> Maybe Message -- Nothing => OK
\begin{code}
lintCoreExpr :: CoreExpr -> LintM Type
-lintCoreExpr (Var var)
- | isConstantId var = returnL (idType var)
- -- Micro-hack here... Class decls generate applications of their
- -- dictionary constructor, but don't generate a binding for the
- -- constructor (since it would never be used). After a single round
- -- of simplification, these dictionary constructors have been
- -- inlined (from their UnfoldInfo) to CoCons. Just between
- -- desugaring and simplfication, though, they appear as naked, unbound
- -- variables as the function in an application.
- -- The hack here simply doesn't check for out-of-scope-ness for
- -- data constructors (at least, in a function position).
- -- Ditto primitive Ids
-
- | otherwise = checkIdInScope var `seqL` returnL (idType var)
+lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
+lintCoreExpr (Lit lit) = returnL (literalType lit)
lintCoreExpr (Note (Coerce to_ty from_ty) expr)
= 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)
where
bndrs = map fst pairs
-lintCoreExpr e@(Con con args)
- = addLoc (AnExpr e) $
- checkL (conOkForApp con) (mkConAppMsg e) `seqL`
- lintCoreArgs (conType con) args
-
lintCoreExpr e@(App fun arg)
= lintCoreExpr fun `thenL` \ ty ->
addLoc (AnExpr e) $
= checkL (null args) (mkDefaultArgsMsg args) `seqL`
lintCoreExpr rhs
-lintCoreAlt scrut_ty alt@(con, args, rhs)
- = addLoc (CaseAlt alt) (
+lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
+ = checkL (null args) (mkDefaultArgsMsg args) `seqL`
+ checkTys lit_ty scrut_ty
+ (mkBadPatMsg lit_ty scrut_ty) `seqL`
+ lintCoreExpr rhs
+ where
+ lit_ty = literalType lit
- checkL (conOkForAlt con) (mkConAltMsg con) `seqL`
+lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
+ = addLoc (CaseAlt alt) (
mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
(mkUnboxedTupleMsg arg)) args `seqL`
-- 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) ->
- lintTyApps (conType con) tycon_arg_tys `thenL` \ con_type ->
- lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
+ 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)
} `seqL`
%************************************************************************
\begin{code}
-lintBinder :: IdOrTyVar -> LintM ()
+lintBinder :: Var -> LintM ()
lintBinder v = nopL
-- ToDo: lint its type
addLoc extra_loc m loc scope errs
= m (extra_loc:loc) scope errs
-addInScopeVars :: [IdOrTyVar] -> LintM a -> LintM a
+addInScopeVars :: [Var] -> LintM a -> LintM a
addInScopeVars ids m loc scope errs
= m loc (scope `unionVarSet` mkVarSet ids) errs
\end{code}
\begin{code}
-checkIdInScope :: IdOrTyVar -> LintM ()
+checkIdInScope :: Var -> LintM ()
checkIdInScope id
= checkInScope (ptext SLIT("is out of scope")) id
-checkBndrIdInScope :: IdOrTyVar -> IdOrTyVar -> LintM ()
+checkBndrIdInScope :: Var -> Var -> LintM ()
checkBndrIdInScope binder id
= checkInScope msg id
where
msg = ptext SLIT("is out of scope inside info for") <+>
ppr binder
-checkInScope :: SDoc -> IdOrTyVar -> LintM ()
+checkInScope :: SDoc -> Var -> LintM ()
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
+ && not (isId var && mayHaveNoBinding var)
+ -- Micro-hack here... Class decls generate applications of their
+ -- dictionary constructor, but don't generate a binding for the
+ -- constructor (since it would never be used). After a single round
+ -- of simplification, these dictionary constructors have been
+ -- inlined (from their UnfoldInfo) to CoCons. Just between
+ -- desugaring and simplfication, though, they appear as naked, unbound
+ -- variables as the function in an application.
+ -- The hack here simply doesn't check for out-of-scope-ness for
+ -- data constructors (at least, in a function position).
+ -- Ditto primitive Ids
= (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
| otherwise
= (Nothing,errs)
------------------------------------------------------
-- Messages for case expressions
-mkConAppMsg :: CoreExpr -> Message
-mkConAppMsg e
- = hang (text "Application of newtype constructor:")
- 4 (ppr e)
-
-mkConAltMsg :: Con -> Message
-mkConAltMsg con
- = text "PrimOp in case pattern:" <+> ppr con
-
mkNullAltsMsg :: CoreExpr -> Message
mkNullAltsMsg e
= hang (text "Case expression with no alternatives:")
4 (ppr e)
-mkDefaultArgsMsg :: [IdOrTyVar] -> Message
+mkDefaultArgsMsg :: [Var] -> Message
mkDefaultArgsMsg args
= hang (text "DEFAULT case with binders")
4 (ppr args)
------------------------------------------------------
-- Other error messages
-mkAppMsg :: Type -> Type -> Message
mkAppMsg fun arg
= vcat [ptext SLIT("Argument value doesn't match argument type:"),
hang (ptext SLIT("Fun type:")) 4 (ppr fun),
projects / ghc-hetmet.git / blobdiff