import CoreSyn
import CoreFVs ( idFreeVars )
-import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
+import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize )
import Unify ( coreRefineTys )
import Bag
import Literal ( literalType )
-import DataCon ( dataConRepType, isVanillaDataCon, dataConTyCon )
-import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
+import DataCon ( dataConRepType, isVanillaDataCon, dataConTyCon, dataConWorkId )
+import TysWiredIn ( tupleCon )
+import Var ( Var, Id, TyVar, idType, tyVarKind, mustHaveLocalBinding )
import VarSet
import Name ( getSrcLoc )
import PprCore
import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
mkLocMessage, debugTraceMsg )
import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan )
-import Type ( Type, tyVarsOfType, eqType,
- splitFunTy_maybe,
+import Type ( Type, tyVarsOfType, coreEqType,
+ splitFunTy_maybe, mkTyVarTys,
splitForAllTy_maybe, splitTyConApp_maybe,
- isUnLiftedType, typeKind,
+ isUnLiftedType, typeKind, mkForAllTy, mkFunTy,
isUnboxedTupleType, isSubKind,
substTyWith, emptyTvSubst, extendTvInScope,
- TvSubst, TvSubstEnv, setTvSubstEnv, substTy,
- extendTvSubst, isInScope )
-import TyCon ( isPrimTyCon, TyCon )
-import BasicTypes ( RecFlag(..), isNonRec )
-import CmdLineOpts
+ TvSubst, TvSubstEnv, mkTvSubst, setTvSubstEnv, substTy,
+ extendTvSubst, composeTvSubst, isInScope,
+ getTvSubstEnv, getTvInScope )
+import TyCon ( isPrimTyCon )
+import BasicTypes ( RecFlag(..), Boxity(..), isNonRec )
+import StaticFlags ( opt_PprStyle_Debug )
+import DynFlags ( DynFlags, DynFlag(..), dopt )
import Outputable
#ifdef DEBUG
= do
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
- debugTraceMsg dflags $
- " Result size = " ++ show (coreBindsSize binds)
+ debugTraceMsg dflags 2 $
+ (text " Result size =" <+> int (coreBindsSize binds))
-- Report verbosely, if required
dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
--
-- Things are *not* OK if:
--
- -- * Unsaturated type app before specialisation has been done;
+ -- * Unsaturated type app before specialisation has been done;
--
- -- * Oversaturated type app after specialisation (eta reduction
+ -- * Oversaturated type app after specialisation (eta reduction
-- may well be happening...);
\begin{code}
= case (initL (lint_binds binds)) of
Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
Just bad_news -> printDump (display bad_news) >>
- ghcExit 1
+ ghcExit dflags 1
where
-- Put all the top-level binders in scope at the start
-- This is because transformation rules can bring something
%************************************************************************
\begin{code}
+type InType = Type -- Substitution not yet applied
+type OutType = Type -- Substitution has been applied to this
-lintCoreExpr :: CoreExpr -> LintM Type
+lintCoreExpr :: CoreExpr -> LintM OutType
-- The returned type has the substitution from the monad
-- already applied to it:
--- lintCoreExpr e subst = exprTpye (subst e)
+-- lintCoreExpr e subst = exprType (subst e)
lintCoreExpr (Var var)
= do { checkIdInScope var
where
bndrs = map fst pairs
-lintCoreExpr (App fun (Type ty))
+lintCoreExpr e@(App fun (Type ty))
-- This is like 'let' for types
-- It's needed when dealing with desugarer output for GADTs. Consider
-- data T = forall a. T a (a->Int) Bool
-- False -> fail)
-- ) a
-- Now the inner case look as though it has incompatible branches.
- = go fun [ty]
+ = addLoc (AnExpr e) $
+ go fun [ty]
where
go (App fun (Type ty)) tys
= do { go fun (ty:tys) }
; lintCoreArgs fun_ty (map Type tys) }
lintCoreExpr e@(App fun arg)
- = do { ty <- lintCoreExpr fun
+ = do { fun_ty <- lintCoreExpr fun
; addLoc (AnExpr e) $
- lintCoreArg ty arg }
+ lintCoreArg fun_ty arg }
lintCoreExpr (Lam var expr)
= addLoc (LambdaBodyOf var) $
- do { lintBinder var
- ; ty <- addInScopeVars [var] $
- lintCoreExpr expr
- ; applySubst (mkPiType var ty) }
+ do { body_ty <- addInScopeVars [var] $
+ lintCoreExpr expr
+ ; if isId var then do
+ { var_ty <- lintId var
+ ; return (mkFunTy var_ty body_ty) }
+ else
+ return (mkForAllTy var body_ty)
+ }
-- The applySubst is needed to apply the subst to var
lintCoreExpr e@(Case scrut var alt_ty alts) =
do { res <- lintCoreArg ty a
; lintCoreArgs res args }
-lintCoreArg ty a@(Type arg_ty) =
+lintCoreArg fun_ty a@(Type arg_ty) =
do { arg_ty <- lintTy arg_ty
- ; lintTyApp ty arg_ty }
+ ; lintTyApp fun_ty arg_ty }
lintCoreArg fun_ty arg =
-- Make sure function type matches argument
do { arg_ty <- lintCoreExpr arg
- ; let err = mkAppMsg fun_ty arg_ty
+ ; let err = mkAppMsg fun_ty arg_ty arg
; case splitFunTy_maybe fun_ty of
Just (arg,res) ->
do { checkTys arg arg_ty err
%************************************************************************
\begin{code}
-checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
+checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
-- a) Check that the alts are non-empty
--- b) Check that the DEFAULT comes first, if it exists
+-- b1) Check that the DEFAULT comes first, if it exists
+-- b2) Check that the others are in increasing order
-- c) Check that there's a default for infinite types
-- NB: Algebraic cases are not necessarily exhaustive, because
-- the simplifer correctly eliminates case that can't
checkCaseAlts e ty alts =
do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
+ ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
; checkL (isJust maybe_deflt || not is_infinite_ty)
(nonExhaustiveAltsMsg e) }
where
(con_alts, maybe_deflt) = findDefault alts
+ -- Check that successive alternatives have increasing tags
+ increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
+ increasing_tag other = True
+
non_deflt (DEFAULT, _, _) = False
non_deflt alt = True
\end{code}
\begin{code}
-checkAltExpr :: CoreExpr -> Type -> LintM ()
-checkAltExpr expr ty
+checkAltExpr :: CoreExpr -> OutType -> LintM ()
+checkAltExpr expr ann_ty
= do { actual_ty <- lintCoreExpr expr
- ; ty' <- applySubst ty
- ; checkTys actual_ty ty' (mkCaseAltMsg expr actual_ty ty') }
+ ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
-lintCoreAlt :: Type -- Type of scrutinee
- -> Type -- Type of the alternative
+lintCoreAlt :: OutType -- Type of scrutinee
+ -> OutType -- Type of the alternative
-> CoreAlt
-> LintM ()
lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
do { checkL (null args) (mkDefaultArgsMsg args)
- ; checkTys lit_ty scrut_ty
- (mkBadPatMsg lit_ty scrut_ty)
+ ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
; checkAltExpr rhs alt_ty }
where
lit_ty = literalType lit
lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
- | isVanillaDataCon con
+ | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty,
+ tycon == dataConTyCon con
= addLoc (CaseAlt alt) $
- addInScopeVars args $
- do { mapM lintBinder args
- -- FIX! Add check that all args are Ids.
- -- 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
-
- ; case splitTyConApp_maybe scrut_ty of {
- Just (tycon, tycon_arg_tys) ->
- do { con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
+ addInScopeVars args $ -- Put the args in scope before lintBinder,
+ -- because the Ids mention the type variables
+ if isVanillaDataCon con then
+ do { addLoc (CasePat alt) $ do
+ { mapM lintBinder args
+ -- FIX! Add check that all args are Ids.
+ -- 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
+
+ ; con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
-- Can just map Var as we know that this is a vanilla datacon
- ; con_result_ty <- lintCoreArgs con_type (map Var args)
- ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
- -- Check the RHS
- ; checkAltExpr rhs alt_ty } ;
- Nothing -> addErrL (mkBadAltMsg scrut_ty alt)
- } }
-
- | otherwise
- = addLoc (CaseAlt alt) $
- addInScopeVars args $ -- Put the args in scope before lintBinder, because
- -- the Ids mention the type variables
- do { mapM lintBinder args
- ; case splitTyConApp_maybe scrut_ty of {
- Nothing -> addErrL (mkBadAltMsg scrut_ty alt) ;
- Just (tycon, tycon_args_tys) ->
- do { checkL (tycon == dataConTyCon con) (mkIncTyconMsg tycon alt)
- ; pat_res_ty <- lintCoreArgs (dataConRepType con) (map varToCoreExpr args)
- ; subst <- getTvSubst
- ; case coreRefineTys args subst pat_res_ty scrut_ty of
- Just senv -> updateTvSubstEnv senv (checkAltExpr rhs alt_ty)
- Nothing -> return () -- Alternative is dead code
- } } }
+ ; con_result_ty <- lintCoreArgs con_type (map Var args)
+ ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
+ }
+ -- Check the RHS
+ ; checkAltExpr rhs alt_ty }
+
+ else -- GADT
+ do { let (tvs,ids) = span isTyVar args
+ ; subst <- getTvSubst
+ ; let in_scope = getTvInScope subst
+ subst_env = getTvSubstEnv subst
+ ; case coreRefineTys in_scope con tvs scrut_ty of {
+ Nothing -> return () ; -- Alternative is dead code
+ Just (refine, _) -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
+ do { addLoc (CasePat alt) $ do
+ { tvs' <- mapM lintTy (mkTyVarTys tvs)
+ ; con_type <- lintTyApps (dataConRepType con) tvs'
+ ; mapM lintBinder ids -- Lint Ids in the refined world
+ ; lintCoreArgs con_type (map Var ids)
+ }
+
+ ; let refined_alt_ty = substTy (mkTvSubst in_scope refine) alt_ty
+ -- alt_ty is already an OutType, so don't re-apply
+ -- the current substitution. But we must apply the
+ -- refinement so that the check in checkAltExpr is ok
+ ; checkAltExpr rhs refined_alt_ty
+ } } }
+
+ | otherwise -- Scrut-ty is wrong shape
+ = addErrL (mkBadAltMsg scrut_ty alt)
\end{code}
%************************************************************************
lintBinder var | isId var = lintId var >> return ()
| otherwise = return ()
-lintId :: Var -> LintM Type
+lintId :: Var -> LintM OutType
-- ToDo: lint its rules
lintId id
= do { checkL (not (isUnboxedTupleType (idType id)))
-- No variable can be bound to an unboxed tuple.
; lintTy (idType id) }
-lintTy :: Type -> LintM Type
+lintTy :: InType -> LintM OutType
-- Check the type, and apply the substitution to it
-- ToDo: check the kind structure of the type
lintTy ty
= RhsOf Id -- The variable bound
| LambdaBodyOf Id -- The lambda-binder
| BodyOfLetRec [Id] -- One of the binders
- | CaseAlt CoreAlt -- Pattern of a case alternative
+ | CaseAlt CoreAlt -- Case alternative
+ | CasePat CoreAlt -- *Pattern* of the case alternative
| AnExpr CoreExpr -- Some expression
| ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
\end{code}
addInScopeVars vars m =
LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
--- gaw 2004
updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
updateTvSubstEnv substenv m =
LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)
\begin{code}
checkIdInScope :: Var -> LintM ()
checkIdInScope id
- = checkInScope (ptext SLIT("is out of scope")) id
+ = do { checkL (not (id == oneTupleDataConId))
+ (ptext SLIT("Illegal one-tuple"))
+ ; checkInScope (ptext SLIT("is out of scope")) id }
+
+oneTupleDataConId :: Id -- Should not happen
+oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
checkBndrIdInScope :: Var -> Var -> LintM ()
checkBndrIdInScope binder id
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
-- Assumes ty1,ty2 are have alrady had the substitution applied
-checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
+checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
\end{code}
%************************************************************************
= (noSrcLoc, text "In the expression:" <+> ppr e)
dumpLoc (CaseAlt (con, args, rhs))
- = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> ppr args))
+ = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
+
+dumpLoc (CasePat (con, args, rhs))
+ = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
dumpLoc (ImportedUnfolding locn)
= (locn, brackets (ptext SLIT("in an imported unfolding")))
mkNonDefltMsg e
= hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
+mkNonIncreasingAltsMsg e
+ = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
nonExhaustiveAltsMsg :: CoreExpr -> Message
nonExhaustiveAltsMsg e
text "Scrutinee type:" <+> ppr scrut_ty,
text "Alternative:" <+> pprCoreAlt alt ]
-mkIncTyconMsg :: TyCon -> CoreAlt -> Message
-mkIncTyconMsg tycon1 alt@(DataAlt con,_,_)
- = vcat [ text "Incompatible tycon applications in alternative",
- text "Scrutinee tycon:" <+> ppr tycon1,
- text "Alternative tycon:" <+> ppr (dataConTyCon con),
- text "Alternative:" <+> pprCoreAlt alt ]
-
------------------------------------------------------
-- Other error messages
-mkAppMsg :: Type -> Type -> Message
-mkAppMsg fun arg
+mkAppMsg :: Type -> Type -> CoreExpr -> Message
+mkAppMsg fun_ty arg_ty arg
= vcat [ptext SLIT("Argument value doesn't match argument type:"),
- hang (ptext SLIT("Fun type:")) 4 (ppr fun),
- hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
+ hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty),
+ hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
+ hang (ptext SLIT("Arg:")) 4 (ppr arg)]
mkKindErrMsg :: TyVar -> Type -> Message
mkKindErrMsg tyvar arg_ty
projects / ghc-hetmet.git / blobdiff