X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=732ab7a7dba716fd8fe55ff6087f1c2e86af0381;hb=d2ca68e80206520e7468e9bea053573d1026433e;hp=ee6541e173b52bf96f263180c08577788aafe888;hpb=b06d623b2e367a572de5daf06d6a0b12c2740471;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index ee6541e..732ab7a 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,29 +95,11 @@ 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 } +lintCoreBindings :: [CoreBind] -> (Bag Message, Bag Message) +-- Returns (warnings, errors) +lintCoreBindings binds + = initL (lint_binds binds) where - (warns, errs) = initL (lint_binds binds) - -- Put all the top-level binders in scope at the start -- This is because transformation rules can bring something -- into use 'unexpectedly' @@ -128,13 +109,6 @@ lintCoreBindings dflags whoDunnit binds 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 +128,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 $ @@ -239,8 +213,7 @@ lintCoreExpr (Var var) ; checkDeadIdOcc var ; var' <- lookupIdInScope var - ; return (idType var') - } + ; return (idType var') } lintCoreExpr (Lit lit) = return (literalType lit) @@ -345,38 +318,53 @@ 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) + | isTyVar 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} @@ -472,7 +460,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 +471,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 @@ -969,7 +947,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