X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=428cda8dec8197ca1b2d815ecd46e27a57589dd5;hp=4893885e6e4453932f06bd00cf6dc32669d012d8;hb=491b818a4a9bd2160107178499e160d62933f58c;hpb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 4893885..428cda8 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -36,7 +36,6 @@ import BasicTypes import StaticFlags import ListSetOps import PrelNames -import DynFlags import Outputable import FastString import Util @@ -96,45 +95,36 @@ find an occurence of an Id, we fetch it from the in-scope set. \begin{code} -lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO () - -lintCoreBindings dflags _whoDunnit _binds - | not (dopt Opt_DoCoreLinting dflags) - = return () - -lintCoreBindings dflags whoDunnit binds - | isEmptyBag errs - = do { showPass dflags ("Core Linted result of " ++ whoDunnit) - ; unless (isEmptyBag warns || opt_NoDebugOutput) $ printDump $ - (banner "warnings" $$ displayMessageBag warns) - ; return () } - - | otherwise - = do { printDump (vcat [ banner "errors", displayMessageBag errs - , ptext (sLit "*** Offending Program ***") - , pprCoreBindings binds - , ptext (sLit "*** End of Offense ***") ]) - - ; ghcExit dflags 1 } - where - (warns, errs) = initL (lint_binds binds) - +lintCoreBindings :: [CoreBind] -> (Bag Message, Bag Message) +-- Returns (warnings, errors) +lintCoreBindings binds + = initL $ + addLoc TopLevelBindings $ + addInScopeVars binders $ -- 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 = addLoc TopLevelBindings $ - addInScopeVars (bindersOfBinds binds) $ - mapM lint_bind binds + do { checkL (null dups) (dupVars dups) + ; checkL (null ext_dups) (dupExtVars ext_dups) + ; mapM lint_bind binds } + where + binders = bindersOfBinds binds + (_, dups) = removeDups compare binders + + -- dups_ext checks for names with different uniques + -- but but the same External name M.n. We don't + -- allow this at top level: + -- M.n{r3} = ... + -- M.n{r29} = ... + -- becuase they both get the same linker symbol + ext_dups = snd (removeDups ord_ext (map Var.varName binders)) + ord_ext n1 n2 | Just m1 <- nameModule_maybe n1 + , Just m2 <- nameModule_maybe n2 + = compare (m1, nameOccName n1) (m2, nameOccName n2) + | otherwise = LT lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs) - - banner string = ptext (sLit "*** Core Lint") <+> text string - <+> ptext (sLit ": in result of") <+> text whoDunnit - <+> ptext (sLit "***") - -displayMessageBag :: Bag Message -> SDoc -displayMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) \end{code} %************************************************************************ @@ -154,7 +144,7 @@ lintUnfolding :: SrcLoc lintUnfolding locn vars expr | isEmptyBag errs = Nothing - | otherwise = Just (displayMessageBag errs) + | otherwise = Just (pprMessageBag errs) where (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $ addInScopeVars vars $ @@ -237,10 +227,13 @@ lintCoreExpr (Var var) = do { checkL (not (var == oneTupleDataConId)) (ptext (sLit "Illegal one-tuple")) - ; checkDeadIdOcc var + ; checkL (not (var `hasKey` wildCardKey)) + (ptext (sLit "Occurence of a wild-card binder") <+> ppr var) + -- See Note [WildCard binders] in SimplEnv + + ; checkDeadIdOcc var ; var' <- lookupIdInScope var - ; return (idType var') - } + ; return (idType var') } lintCoreExpr (Lit lit) = return (literalType lit) @@ -256,9 +249,9 @@ lintCoreExpr (Note _ expr) = lintCoreExpr expr lintCoreExpr (Let (NonRec tv (Type ty)) body) - = -- See Note [Type let] in CoreSyn - do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate - ; ty' <- lintInTy ty + | isTyVar tv + = -- See Note [Linting type lets] + do { ty' <- addLoc (RhsOf tv) $ lintInTy ty ; lintTyBndr tv $ \ tv' -> addLoc (BodyOfLetRec [tv]) $ extendSubstL tv' ty' $ do @@ -267,6 +260,19 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body) -- take advantage of it in the body ; lintCoreExpr body } } + | isCoVar tv + = do { co <- applySubst ty + ; (s1,s2) <- addLoc (RhsOf tv) $ lintCoercion co + ; lintTyBndr tv $ \ tv' -> + addLoc (BodyOfLetRec [tv]) $ do + { let (t1,t2) = coVarKind tv' + ; checkTys s1 t1 (mkTyVarLetErr tv ty) + ; checkTys s2 t2 (mkTyVarLetErr tv ty) + ; lintCoreExpr body } } + + | otherwise + = failWithL (mkTyVarLetErr tv ty) -- Not quite accurate + lintCoreExpr (Let (NonRec bndr rhs) body) = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) ; addLoc (BodyOfLetRec [bndr]) @@ -274,10 +280,12 @@ lintCoreExpr (Let (NonRec bndr rhs) body) lintCoreExpr (Let (Rec pairs) body) = lintAndScopeIds bndrs $ \_ -> - do { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs + do { checkL (null dups) (dupVars dups) + ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) } where bndrs = map fst pairs + (_, dups) = removeDups compare bndrs lintCoreExpr e@(App fun arg) = do { fun_ty <- lintCoreExpr fun @@ -286,8 +294,9 @@ lintCoreExpr e@(App fun arg) lintCoreExpr (Lam var expr) = addLoc (LambdaBodyOf var) $ - lintBinders [var] $ \[var'] -> - do { body_ty <- lintCoreExpr expr + lintBinders [var] $ \ vars' -> + do { let [var'] = vars' + ; body_ty <- lintCoreExpr expr ; if isId var' then return (mkFunTy (idType var') body_ty) else @@ -306,7 +315,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = Just (tycon, _) | debugIsOn && isAlgTyCon tycon && - not (isOpenTyCon tycon) && + not (isFamilyTyCon tycon || isAbstractTyCon tycon) && null (tyConDataCons tycon) -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) -- This can legitimately happen for type families @@ -345,42 +354,57 @@ The basic version of these functions checks that the argument is a subtype of the required type, as one would expect. \begin{code} -lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType -lintCoreArg :: OutType -> CoreArg -> LintM OutType --- First argument has already had substitution applied to it -\end{code} - -\begin{code} -lintCoreArgs ty [] = return ty -lintCoreArgs ty (a : args) = - do { res <- lintCoreArg ty a - ; lintCoreArgs res args } - +lintCoreArg :: OutType -> CoreArg -> LintM OutType lintCoreArg fun_ty (Type arg_ty) - | Just (tyvar,body) <- splitForAllTy_maybe fun_ty = do { arg_ty' <- applySubst arg_ty - ; checkKinds tyvar arg_ty' + ; lintTyApp fun_ty arg_ty' } + +lintCoreArg fun_ty arg + = do { arg_ty <- lintCoreExpr arg + ; lintValApp arg fun_ty arg_ty } + +----------------- +lintAltBinders :: OutType -- Scrutinee type + -> OutType -- Constructor type + -> [OutVar] -- Binders + -> LintM () +lintAltBinders scrut_ty con_ty [] + = checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) +lintAltBinders scrut_ty con_ty (bndr:bndrs) + | isTyCoVar bndr + = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) + ; lintAltBinders scrut_ty con_ty' bndrs } + | otherwise + = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr) + ; lintAltBinders scrut_ty con_ty' bndrs } + +----------------- +lintTyApp :: OutType -> OutType -> LintM OutType +lintTyApp fun_ty arg_ty + | Just (tyvar,body_ty) <- splitForAllTy_maybe fun_ty + = do { checkKinds tyvar arg_ty ; if isCoVar tyvar then - return body -- Co-vars don't appear in body! + return body_ty -- Co-vars don't appear in body_ty! else - return (substTyWith [tyvar] [arg_ty'] body) } + return (substTyWith [tyvar] [arg_ty] body_ty) } | otherwise = failWithL (mkTyAppMsg fun_ty arg_ty) - -lintCoreArg fun_ty arg - -- Make sure function type matches argument - = do { arg_ty <- lintCoreExpr arg - ; let err1 = mkAppMsg fun_ty arg_ty arg - err2 = mkNonFunAppMsg fun_ty arg_ty arg - ; case splitFunTy_maybe fun_ty of - Just (arg,res) -> - do { checkTys arg arg_ty err1 - ; return res } - _ -> failWithL err2 } + +----------------- +lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType +lintValApp arg fun_ty arg_ty + | Just (arg,res) <- splitFunTy_maybe fun_ty + = do { checkTys arg arg_ty err1 + ; return res } + | otherwise + = failWithL err2 + where + err1 = mkAppMsg fun_ty arg_ty arg + err2 = mkNonFunAppMsg fun_ty arg_ty arg \end{code} \begin{code} -checkKinds :: Var -> OutType -> LintM () +checkKinds :: OutVar -> OutType -> LintM () -- Both args have had substitution applied checkKinds tyvar arg_ty -- Arg type might be boxed for a function with an uncommitted @@ -472,7 +496,8 @@ lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) = lit_ty = literalType lit lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) - | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt) + | isNewTyCon (dataConTyCon con) + = addErrL (mkNewTyDataConAltMsg scrut_ty alt) | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty = addLoc (CaseAlt alt) $ do { -- First instantiate the universally quantified @@ -482,19 +507,8 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys -- And now bring the new binders into scope - ; lintBinders args $ \ args -> do - { addLoc (CasePat alt) $ 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 - ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args) - ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) - } - -- Check the RHS + ; lintBinders args $ \ args' -> do + { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args') ; checkAltExpr rhs alt_ty } } | otherwise -- Scrut-ty is wrong shape @@ -613,30 +627,32 @@ lintSplitCoVar cv , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))]) ------------------- -lintCoercion :: OutType -> LintM (OutType, OutType) +lintCoercion, lintCoercion' :: OutType -> LintM (OutType, OutType) -- Check the kind of a coercion term, returning the kind -lintCoercion ty@(TyVarTy tv) +lintCoercion co + = addLoc (InCoercion co) $ lintCoercion' co + +lintCoercion' ty@(TyVarTy tv) = do { checkTyVarInScope tv ; if isCoVar tv then return (coVarKind tv) else return (ty, ty) } -lintCoercion ty@(AppTy ty1 ty2) +lintCoercion' ty@(AppTy ty1 ty2) = do { (s1,t1) <- lintCoercion ty1 ; (s2,t2) <- lintCoercion ty2 ; check_co_app ty (typeKind s1) [s2] - ; return (AppTy s1 s2, AppTy t1 t2) } + ; return (mkAppTy s1 s2, mkAppTy t1 t2) } -lintCoercion ty@(FunTy ty1 ty2) +lintCoercion' ty@(FunTy ty1 ty2) = do { (s1,t1) <- lintCoercion ty1 ; (s2,t2) <- lintCoercion ty2 ; check_co_app ty (tyConKind funTyCon) [s1, s2] ; return (FunTy s1 s2, FunTy t1 t2) } -lintCoercion ty@(TyConApp tc tys) - | Just (ar, rule) <- isCoercionTyCon_maybe tc +lintCoercion' ty@(TyConApp tc tys) + | Just (ar, desc) <- isCoercionTyCon_maybe tc = do { unless (tys `lengthAtLeast` ar) (badCo ty) - ; (s,t) <- rule lintType lintCoercion - True (take ar tys) + ; (s,t) <- lintCoTyConApp ty desc (take ar tys) ; (ss,ts) <- mapAndUnzipM lintCoercion (drop ar tys) ; check_co_app ty (typeKind s) ss ; return (mkAppTys s ss, mkAppTys t ts) } @@ -649,19 +665,19 @@ lintCoercion ty@(TyConApp tc tys) ; check_co_app ty (tyConKind tc) ss ; return (TyConApp tc ss, TyConApp tc ts) } -lintCoercion ty@(PredTy (ClassP cls tys)) +lintCoercion' ty@(PredTy (ClassP cls tys)) = do { (ss,ts) <- mapAndUnzipM lintCoercion tys ; check_co_app ty (tyConKind (classTyCon cls)) ss ; return (PredTy (ClassP cls ss), PredTy (ClassP cls ts)) } -lintCoercion (PredTy (IParam n p_ty)) +lintCoercion' (PredTy (IParam n p_ty)) = do { (s,t) <- lintCoercion p_ty ; return (PredTy (IParam n s), PredTy (IParam n t)) } -lintCoercion ty@(PredTy (EqPred {})) +lintCoercion' ty@(PredTy (EqPred {})) = failWithL (badEq ty) -lintCoercion (ForAllTy tv ty) +lintCoercion' (ForAllTy tv ty) | isCoVar tv = do { (co1, co2) <- lintSplitCoVar tv ; (s1,t1) <- lintCoercion co1 @@ -677,6 +693,70 @@ lintCoercion (ForAllTy tv ty) badCo :: Coercion -> LintM a badCo co = failWithL (hang (ptext (sLit "Ill-kinded coercion term:")) 2 (ppr co)) +--------------- +lintCoTyConApp :: Coercion -> CoTyConDesc -> [Coercion] -> LintM (Type,Type) +-- Always called with correct number of coercion arguments +-- First arg is just for error message +lintCoTyConApp _ CoLeft (co:_) = lintLR fst co +lintCoTyConApp _ CoRight (co:_) = lintLR snd co +lintCoTyConApp _ CoCsel1 (co:_) = lintCsel fstOf3 co +lintCoTyConApp _ CoCsel2 (co:_) = lintCsel sndOf3 co +lintCoTyConApp _ CoCselR (co:_) = lintCsel thirdOf3 co + +lintCoTyConApp _ CoSym (co:_) + = do { (ty1,ty2) <- lintCoercion co + ; return (ty2,ty1) } + +lintCoTyConApp co CoTrans (co1:co2:_) + = do { (ty1a, ty1b) <- lintCoercion co1 + ; (ty2a, ty2b) <- lintCoercion co2 + ; checkL (ty1b `coreEqType` ty2a) + (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) + 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) + ; return (ty1a, ty2b) } + +lintCoTyConApp _ CoInst (co:arg_ty:_) + = do { co_tys <- lintCoercion co + ; arg_kind <- lintType arg_ty + ; case decompInst_maybe co_tys of + Just ((tv1,tv2), (ty1,ty2)) + | arg_kind `isSubKind` tyVarKind tv1 + -> return (substTyWith [tv1] [arg_ty] ty1, + substTyWith [tv2] [arg_ty] ty2) + | otherwise + -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) + Nothing -> failWithL (ptext (sLit "Bad argument of inst")) } + +lintCoTyConApp _ (CoAxiom { co_ax_tvs = tvs + , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos + = do { (tys1, tys2) <- mapAndUnzipM lintCoercion cos + ; sequence_ (zipWith checkKinds tvs tys1) + ; return (substTyWith tvs tys1 lhs_ty, + substTyWith tvs tys2 rhs_ty) } + +lintCoTyConApp _ CoUnsafe (ty1:ty2:_) + = do { _ <- lintType ty1 + ; _ <- lintType ty2 -- Ignore kinds; it's unsafe! + ; return (ty1,ty2) } + +lintCoTyConApp _ _ _ = panic "lintCoTyConApp" -- Called with wrong number of coercion args + +---------- +lintLR :: (forall a. (a,a)->a) -> Coercion -> LintM (Type,Type) +lintLR sel co + = do { (ty1,ty2) <- lintCoercion co + ; case decompLR_maybe (ty1,ty2) of + Just res -> return (sel res) + Nothing -> failWithL (ptext (sLit "Bad argument of left/right")) } + +---------- +lintCsel :: (forall a. (a,a,a)->a) -> Coercion -> LintM (Type,Type) +lintCsel sel co + = do { (ty1,ty2) <- lintCoercion co + ; case decompCsel_maybe (ty1,ty2) of + Just res -> return (sel res) + Nothing -> failWithL (ptext (sLit "Bad argument of csel")) } + ------------------- lintType :: OutType -> LintM Kind lintType (TyVarTy tv) @@ -794,6 +874,7 @@ data LintLocInfo | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) | TopLevelBindings | InType Type -- Inside a type + | InCoercion Coercion -- Inside a type \end{code} @@ -846,12 +927,7 @@ inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs) addInScopeVars :: [Var] -> LintM a -> LintM a addInScopeVars vars m - | null dups = LintM (\ loc subst errs -> unLintM m loc (extendTvInScopeList subst vars) errs) - | otherwise - = failWithL (dupVars dups) - where - (_, dups) = removeDups compare vars addInScopeVar :: Var -> LintM a -> LintM a addInScopeVar var m @@ -906,7 +982,7 @@ checkInScope loc_msg var = ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) (hsep [ppr var, loc_msg]) } -checkTys :: Type -> Type -> Message -> LintM () +checkTys :: OutType -> OutType -> Message -> LintM () -- 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 @@ -949,6 +1025,8 @@ dumpLoc TopLevelBindings = (noSrcLoc, empty) dumpLoc (InType ty) = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) +dumpLoc (InCoercion ty) + = (noSrcLoc, text "In the coercion" <+> quotes (ppr ty)) pp_binders :: [Var] -> SDoc pp_binders bs = sep (punctuate comma (map pp_binder bs)) @@ -1040,6 +1118,14 @@ mkNonFunAppMsg fun_ty arg_ty arg hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), hang (ptext (sLit "Arg:")) 4 (ppr arg)] +mkTyVarLetErr :: TyVar -> Type -> Message +mkTyVarLetErr tyvar ty + = vcat [ptext (sLit "Bad `let' binding for type or coercion variable:"), + hang (ptext (sLit "Type/coercion variable:")) + 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), + hang (ptext (sLit "Arg type/coercion:")) + 4 (ppr ty)] + mkKindErrMsg :: TyVar -> Type -> Message mkKindErrMsg tyvar arg_ty = vcat [ptext (sLit "Kinds don't match in type application:"), @@ -1115,4 +1201,9 @@ dupVars :: [[Var]] -> Message dupVars vars = hang (ptext (sLit "Duplicate variables brought into scope")) 2 (ppr vars) + +dupExtVars :: [[Name]] -> Message +dupExtVars vars + = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) + 2 (ppr vars) \end{code}