X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=5cc82a2ae220f623627bc573880cc7ce006499d5;hb=841e81e28f8cc711f624fdca122219a5bbde2fae;hp=119b2320cb4d990133e0074ba834ceaa6a31ed46;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 119b232..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,7 +227,7 @@ lintCoreExpr (Var var) = do { checkL (not (var == oneTupleDataConId)) (ptext (sLit "Illegal one-tuple")) - ; checkDeadIdOcc var + ; checkDeadIdOcc var ; var' <- lookupIdInScope var ; return (idType var') } @@ -260,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 @@ -272,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 @@ -381,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 @@ -604,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) @@ -639,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 @@ -848,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} @@ -900,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 @@ -1003,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)) @@ -1177,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}