From b7cc3d012a98cc49abb3441e6637d5148f57f1d1 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 27 Sep 2002 08:16:25 +0000 Subject: [PATCH] [project @ 2002-09-27 08:16:24 by simonpj] -------------------------------- Do type-checking of external-core input -------------------------------- When we read in an External Core file, we should really type-check it. We weren't, because we treated it as if it were trusted, interface-file material. This commit fixes the problem, albeit in a bit of a hacky way. The typechecking is done by Lint, which does not give as friendly error messages as does the normal typechecker. But it's much better than nothing. I also removed the entirely-unused 'warnings' from the Lint monad. --- ghc/compiler/coreSyn/CoreLint.lhs | 89 ++++++++++++--------------------- ghc/compiler/typecheck/TcIfaceSig.lhs | 30 +++++++---- 2 files changed, 52 insertions(+), 67 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index a5785ac..0ed2a1c 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -116,13 +116,9 @@ lintCoreBindings dflags whoDunnit binds lintCoreBindings dflags whoDunnit binds = case (initL (lint_binds binds)) of - (Nothing, Nothing) -> done_lint - - (Nothing, Just warnings) -> printDump (warn warnings) >> - done_lint - - (Just bad_news, warns) -> printDump (display bad_news warns) >> - ghcExit 1 + Nothing -> done_lint + Just bad_news -> printDump (display bad_news) >> + ghcExit 1 where -- Put all the top-level binders in scope at the start -- This is because transformation rules can bring something @@ -136,22 +132,10 @@ lintCoreBindings dflags whoDunnit binds done_lint = doIfSet (verbosity dflags >= 2) (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n")) - warn warnings - = vcat [ - text ("*** Core Lint Warnings: in result of " ++ whoDunnit ++ " ***"), - warnings, - offender - ] - - display bad_news warns - = vcat [ - text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), - bad_news, - maybe offender warn warns -- either offender or warnings (with offender) - ] - offender - = vcat [ + display bad_news + = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), + bad_news, ptext SLIT("*** Offending Program ***"), pprCoreBindings binds, ptext SLIT("*** End of Offense ***") @@ -168,17 +152,12 @@ We use this to check all unfoldings that come in from interfaces (it is very painful to catch errors otherwise): \begin{code} -lintUnfolding :: DynFlags - -> SrcLoc +lintUnfolding :: SrcLoc -> [Var] -- Treat these as in scope -> CoreExpr - -> (Maybe Message, Maybe Message) -- (Nothing,_) => OK + -> Maybe Message -- Nothing => OK -lintUnfolding dflags locn vars expr - | not (dopt Opt_DoCoreLinting dflags) - = (Nothing, Nothing) - - | otherwise +lintUnfolding locn vars expr = initL (addLoc (ImportedUnfolding locn) $ addInScopeVars vars $ lintCoreExpr expr) @@ -481,8 +460,7 @@ lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL` type LintM a = [LintLocInfo] -- Locations -> IdSet -- Local vars in scope -> Bag Message -- Error messages so far - -> Bag Message -- Warning messages so far - -> (Maybe a, Bag Message, Bag Message) -- Result and error/warning messages (if any) + -> (Maybe a, Bag Message) -- Result and error messages (if any) data LintLocInfo = RhsOf Id -- The variable bound @@ -494,32 +472,28 @@ data LintLocInfo \end{code} \begin{code} -initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -}) +initL :: LintM a -> Maybe Message {- errors -} initL m - = case m [] emptyVarSet emptyBag emptyBag of - (_, errs, warns) -> (ifNonEmptyBag errs, - ifNonEmptyBag warns) - where - ifNonEmptyBag bag - | isEmptyBag bag = Nothing - | otherwise = Just (vcat (punctuate (text "") (bagToList bag))) + = case m [] emptyVarSet emptyBag of + (_, errs) | isEmptyBag errs -> Nothing + | otherwise -> Just (vcat (punctuate (text "") (bagToList errs))) returnL :: a -> LintM a -returnL r loc scope errs warns = (Just r, errs, warns) +returnL r loc scope errs = (Just r, errs) nopL :: LintM a -nopL loc scope errs warns = (Nothing, errs, warns) +nopL loc scope errs = (Nothing, errs) thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k loc scope errs warns - = case m loc scope errs warns of - (Just r, errs', warns') -> k r loc scope errs' warns' - (Nothing, errs', warns') -> (Nothing, errs', warns') +thenL m k loc scope errs + = case m loc scope errs of + (Just r, errs') -> k r loc scope errs' + (Nothing, errs') -> (Nothing, errs') seqL :: LintM a -> LintM b -> LintM b -seqL m k loc scope errs warns - = case m loc scope errs warns of - (_, errs', warns') -> k loc scope errs' warns' +seqL m k loc scope errs + = case m loc scope errs of + (_, errs') -> k loc scope errs' mapL :: (a -> LintM b) -> [a] -> LintM [b] mapL f [] = returnL [] @@ -535,10 +509,9 @@ checkL True msg = nopL checkL False msg = addErrL msg addErrL :: Message -> LintM a -addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns) +addErrL msg loc scope errs = (Nothing, addErr errs msg loc) addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message --- errors or warnings, actually... they're the same type. addErr errs_so_far msg locs = ASSERT( notNull locs ) errs_so_far `snocBag` mk_msg msg @@ -551,12 +524,12 @@ addErr errs_so_far msg locs mk_msg msg = addErrLocHdrLine loc context msg addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m loc scope errs warns - = m (extra_loc:loc) scope errs warns +addLoc extra_loc m loc scope errs + = m (extra_loc:loc) scope errs addInScopeVars :: [Var] -> LintM a -> LintM a -addInScopeVars ids m loc scope errs warns - = m loc (scope `unionVarSet` mkVarSet ids) errs warns +addInScopeVars ids m loc scope errs + = m loc (scope `unionVarSet` mkVarSet ids) errs \end{code} \begin{code} @@ -572,11 +545,11 @@ checkBndrIdInScope binder id ppr binder checkInScope :: SDoc -> Var -> LintM () -checkInScope loc_msg var loc scope errs warns +checkInScope loc_msg var loc scope errs | mustHaveLocalBinding var && not (var `elemVarSet` scope) - = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns) + = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc) | otherwise - = nopL loc scope errs warns + = nopL loc scope errs checkTys :: Type -> Type -> Message -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 5b44886..004d7b5 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -15,7 +15,7 @@ module TcIfaceSig ( tcInterfaceSigs, import HsSyn ( CoreDecl(..), TyClDecl(..), HsTupCon(..) ) import TcHsSyn ( TypecheckedCoreBind ) import TcRnMonad -import TcMonoType ( tcIfaceType ) +import TcMonoType ( tcIfaceType, kcHsSigType ) import TcEnv ( RecTcGblEnv, tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobal_maybe, tcLookupRecId_maybe @@ -43,6 +43,7 @@ import UniqSupply ( initUs_ ) import Outputable import Util ( zipWithEqual, dropList, equalLength ) import HscTypes ( TyThing(..) ) +import CmdLineOpts ( DynFlag(..) ) \end{code} Ultimately, type signatures in interfaces will have pragmatic @@ -150,11 +151,14 @@ tcPragExpr unf_env name in_scope_vars expr tcCoreExpr expr `thenM` \ core_expr' -> -- Check for type consistency in the unfolding - getSrcLocM `thenM` \ src_loc -> - getDOpts `thenM` \ dflags -> - case lintUnfolding dflags src_loc in_scope_vars core_expr' of - (Nothing,_) -> returnM core_expr' -- ignore warnings - (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg) + ifOptM Opt_DoCoreLinting ( + getSrcLocM `thenM` \ src_loc -> + case lintUnfolding src_loc in_scope_vars core_expr' of + Nothing -> returnM () + Just fail_msg -> failWithTc ((doc <+> text "Failed Lint") $$ fail_msg) + ) `thenM_` + + returnM core_expr' where doc = text "unfolding of" <+> ppr name \end{code} @@ -374,15 +378,23 @@ tcCoreBinds :: [RenamedCoreDecl] -> TcM [TypecheckedCoreBind] -- So first build the environment, then check the RHSs tcCoreBinds ls = mappM tcCoreBinder ls `thenM` \ bndrs -> tcExtendGlobalValEnv bndrs $ - mappM tcCoreBind ls + mappM (tcCoreBind bndrs) ls tcCoreBinder (CoreDecl nm ty _ _) - = tcIfaceType ty `thenM` \ ty' -> + = kcHsSigType ty `thenM_` + tcIfaceType ty `thenM` \ ty' -> returnM (mkLocalId nm ty') -tcCoreBind (CoreDecl nm _ rhs _) +tcCoreBind bndrs (CoreDecl nm _ rhs loc) = tcVar nm `thenM` \ id -> tcCoreExpr rhs `thenM` \ rhs' -> + let + mb_err = lintUnfolding loc bndrs rhs' + in + (case mb_err of + Just err -> addErr err + Nothing -> returnM ()) `thenM_` + returnM (id, rhs') \end{code} -- 1.7.10.4