X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=d613e07b6be61aca9f1b61bac87be64cf1c95c9f;hb=53ce311e219dcccf4d205f573c16e23a5c44265e;hp=504f5dabf6ac6655cfc6414333d46d708bb379f4;hpb=ade2eac4257679a3ac152a39df87ce8567bd7766;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 504f5da..d613e07 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -1,10 +1,5 @@ \begin{code} module TcMonad( - TcType, - TcTauType, TcPredType, TcThetaType, TcRhoType, - TcTyVar, TcTyVarSet, TcClassContext, - TcKind, - TcM, NF_TcM, TcDown, TcEnv, initTc, @@ -32,9 +27,9 @@ module TcMonad( tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc, tcAddErrCtxtM, tcSetErrCtxtM, - tcAddErrCtxt, tcSetErrCtxt, + tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt, - tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef, + tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef, tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar, InstOrigin(..), InstLoc, pprInstLoc, @@ -47,18 +42,17 @@ module TcMonad( import {-# SOURCE #-} TcEnv ( TcEnv ) -import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit ) -import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType, - ) +import HsLit ( HsOverLit ) +import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr ) +import TcType ( Type, Kind, TyVarDetails ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg ) import Bag ( Bag, emptyBag, isEmptyBag, foldBag, unitBag, unionBags, snocBag ) -import Class ( Class, ClassContext ) +import Class ( Class ) import Name ( Name ) -import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar ) +import Var ( Id, TyVar, newMutTyVar, readMutTyVar, writeMutTyVar ) import VarEnv ( TidyEnv, emptyTidyEnv ) -import VarSet ( TyVarSet ) import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply, mkSplitUniqSupply, UniqSM, initUs_ ) @@ -79,31 +73,6 @@ infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` %************************************************************************ %* * -\subsection{Types} -%* * -%************************************************************************ - -\begin{code} -type TcTyVar = TyVar -- Might be a mutable tyvar -type TcTyVarSet = TyVarSet - -type TcType = Type -- A TcType can have mutable type variables - -- Invariant on ForAllTy in TcTypes: - -- forall a. T - -- a cannot occur inside a MutTyVar in T; that is, - -- T is "flattened" before quantifying over a - -type TcClassContext = ClassContext -type TcPredType = PredType -type TcThetaType = ThetaType -type TcRhoType = RhoType -type TcTauType = TauType -type TcKind = TcType -\end{code} - - -%************************************************************************ -%* * \subsection{The main monads: TcM, NF_TcM} %* * %************************************************************************ @@ -217,6 +186,12 @@ mapBagTc f bag fixTc :: (a -> TcM a) -> TcM a fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a fixTc m env down = fixIO (\ loop -> m loop env down) +{-# NOINLINE fixTc #-} +-- aargh! Not inlining fixTc alleviates a space leak problem. +-- Normally fixTc is used with a lazy tuple match: if the optimiser is +-- shown the definition of fixTc, it occasionally transforms the code +-- in such a way that the code generator doesn't spot the selector +-- thunks. Sigh. recoverTc :: TcM r -> TcM r -> TcM r recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r @@ -269,7 +244,7 @@ forkNF_Tc m down@(TcDown { tc_us = u_var }) env \begin{code} traceTc :: SDoc -> NF_TcM () traceTc doc (TcDown { tc_dflags=dflags }) env - | dopt Opt_D_dump_rn_trace dflags = printDump doc + | dopt Opt_D_dump_tc_trace dflags = printDump doc | otherwise = return () ioToTc :: IO a -> NF_TcM a @@ -292,7 +267,7 @@ failTc :: TcM a failTc down env = give_up give_up :: IO a -give_up = IOERROR (userError "Typecheck failed") +give_up = ioError (userError "Typecheck failed") failWithTc :: Message -> TcM a -- Add an error message and fail failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg) @@ -388,6 +363,8 @@ tryTc recover main down env m_errs_var <- newIORef (emptyBag,emptyBag) catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var) where + errs_var = getTcErrs down + my_recover m_errs_var = do warns_and_errs <- readIORef m_errs_var recover warns_and_errs down env @@ -400,7 +377,13 @@ tryTc recover main down env -- errors along the way. (m_warns, m_errs) <- readIORef m_errs_var if isEmptyBag m_errs then - return result + -- No errors, so return normally, but don't lose the warnings + if isEmptyBag m_warns then + return result + else + do (warns, errs) <- readIORef errs_var + writeIORef errs_var (warns `unionBags` m_warns, errs) + return result else give_up -- This triggers the catch @@ -458,11 +441,8 @@ tcWriteMutVar var val down env = writeIORef var val tcReadMutVar :: TcRef a -> NF_TcM a tcReadMutVar var down env = readIORef var -tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar -tcNewMutTyVar name kind down env = newMutTyVar name kind - -tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar -tcNewSigTyVar name kind down env = newSigTyVar name kind +tcNewMutTyVar :: Name -> Kind -> TyVarDetails -> NF_TcM TyVar +tcNewMutTyVar name kind details down env = newMutTyVar name kind details tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type) tcReadMutTyVar tyvar down env = readMutTyVar tyvar @@ -518,6 +498,9 @@ tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r -- Usual thing tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env + +tcPopErrCtxt :: Either_TcM r -> Either_TcM r +tcPopErrCtxt m down env = m (popErrCtxt down) env \end{code} @@ -538,11 +521,11 @@ tcGetUnique down env where u_var = getUniqSupplyVar down -tcGetUniques :: Int -> NF_TcM [Unique] -tcGetUniques n down env +tcGetUniques :: NF_TcM [Unique] +tcGetUniques down env = do uniq_supply <- readIORef u_var let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply - uniqs = uniqsFromSupply n uniq_s + uniqs = uniqsFromSupply uniq_s writeIORef u_var new_uniq_supply return uniqs where @@ -601,6 +584,10 @@ getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt setErrCtxt down msg = down{tc_ctxt=[msg]} addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down} +popErrCtxt down = case tc_ctxt down of + [] -> down + m : ms -> down{tc_ctxt = ms} + doptsTc :: DynFlag -> TcM Bool doptsTc dflag (TcDown{tc_dflags=dflags}) env_down = return (dopt dflag dflags) @@ -624,12 +611,7 @@ type TcError = Message type TcWarning = Message ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt - | otherwise = takeAtMost 3 ctxt - where - takeAtMost :: Int -> [a] -> [a] - takeAtMost 0 ls = [] - takeAtMost n [] = [] - takeAtMost n (x:xs) = x:takeAtMost (n-1) xs + | otherwise = take 3 ctxt arityErr kind name n m = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"), @@ -670,7 +652,7 @@ data InstOrigin | InstanceDeclOrigin -- Typechecking an instance decl - | LiteralOrigin RenamedHsOverLit -- Occurrence of a literal + | LiteralOrigin HsOverLit -- Occurrence of a literal | PatOrigin RenamedPat @@ -719,12 +701,16 @@ pprInstLoc (orig, locn, ctxt) = hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)] pp_orig (IPBind name) = hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)] + pp_orig RecordUpdOrigin + = ptext SLIT("a record update") + pp_orig DataDeclOrigin + = ptext SLIT("the data type declaration") + pp_orig InstanceDeclOrigin + = ptext SLIT("the instance declaration") pp_orig (LiteralOrigin lit) = hsep [ptext SLIT("the literal"), quotes (ppr lit)] pp_orig (PatOrigin pat) = hsep [ptext SLIT("the pattern"), quotes (ppr pat)] - pp_orig (InstanceDeclOrigin) - = ptext SLIT("an instance declaration") pp_orig (ArithSeqOrigin seq) = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)] pp_orig (SignatureOrigin)