X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=5cc82a2ae220f623627bc573880cc7ce006499d5;hb=841e81e28f8cc711f624fdca122219a5bbde2fae;hp=c69a9d2f3d12fe0b0f86bf785d3caa22a60fbdaf;hpb=9ce35503f60f190fbd4a7df80cc22a43e223255d;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index c69a9d2..5cc82a2 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -98,14 +98,30 @@ find an occurence of an Id, we fetch it from the in-scope set. lintCoreBindings :: [CoreBind] -> (Bag Message, Bag Message) -- Returns (warnings, errors) lintCoreBindings binds - = initL (lint_binds binds) - where + = 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) @@ -211,10 +227,9 @@ lintCoreExpr (Var var) = do { checkL (not (var == oneTupleDataConId)) (ptext (sLit "Illegal one-tuple")) - ; checkDeadIdOcc var + ; checkDeadIdOcc var ; var' <- lookupIdInScope var - ; return (idType var') - } + ; return (idType var') } lintCoreExpr (Lit lit) = return (literalType lit) @@ -230,9 +245,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 @@ -241,6 +256,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]) @@ -248,10 +276,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 @@ -260,8 +290,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 @@ -280,7 +311,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 @@ -336,7 +367,7 @@ lintAltBinders :: OutType -- Scrutinee type lintAltBinders scrut_ty con_ty [] = checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) lintAltBinders scrut_ty con_ty (bndr:bndrs) - | isTyVar bndr + | isTyCoVar bndr = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) ; lintAltBinders scrut_ty con_ty' bndrs } | otherwise @@ -369,7 +400,7 @@ lintValApp arg fun_ty arg_ty \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 @@ -592,26 +623,29 @@ 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) +lintCoercion' ty@(TyConApp tc tys) | Just (ar, desc) <- isCoercionTyCon_maybe tc = do { unless (tys `lengthAtLeast` ar) (badCo ty) ; (s,t) <- lintCoTyConApp ty desc (take ar tys) @@ -627,19 +661,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 @@ -836,6 +870,7 @@ data LintLocInfo | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) | TopLevelBindings | InType Type -- Inside a type + | InCoercion Coercion -- Inside a type \end{code} @@ -888,12 +923,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 @@ -991,6 +1021,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)) @@ -1082,6 +1114,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:"), @@ -1157,4 +1197,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}