X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=11cb6bdab94ddde75cfa402af7f412360ecae200;hb=979947f545d70c63edb7ca96f6e47008ac90e3bf;hp=b25242c91cb120fdb7be43d347f74c97ebdb3b06;hpb=e2dd0696483f1194e398dc74c115255940ff38d8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index b25242c..11cb6bd 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,22 +42,22 @@ 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_ ) import SrcLoc ( SrcLoc, noSrcLoc ) +import BasicTypes ( IPName ) import UniqFM ( emptyUFM ) import Unique ( Unique ) import CmdLineOpts @@ -79,31 +74,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 +187,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 @@ -268,7 +244,9 @@ forkNF_Tc m down@(TcDown { tc_us = u_var }) env \begin{code} traceTc :: SDoc -> NF_TcM () -traceTc doc down env = printDump doc +traceTc doc (TcDown { tc_dflags=dflags }) env + | dopt Opt_D_dump_tc_trace dflags = printDump doc + | otherwise = return () ioToTc :: IO a -> NF_TcM a ioToTc io down env = io @@ -290,7 +268,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) @@ -386,6 +364,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 @@ -398,7 +378,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 @@ -456,11 +442,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 @@ -505,7 +488,8 @@ tcGetSrcLoc :: NF_TcM SrcLoc tcGetSrcLoc down env = return (getLoc down) tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc -tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down) +tcGetInstLoc origin TcDown{tc_loc=loc, tc_ctxt=ctxt} env + = return (origin, loc, ctxt) tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message)) -> TcM a -> TcM a @@ -516,6 +500,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} @@ -536,11 +523,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 @@ -599,11 +586,15 @@ getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt setErrCtxt down msg = down{tc_ctxt=[msg]} addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down} -doptsTc :: DynFlag -> TcM Bool +popErrCtxt down = case tc_ctxt down of + [] -> down + m : ms -> down{tc_ctxt = ms} + +doptsTc :: DynFlag -> NF_TcM Bool doptsTc dflag (TcDown{tc_dflags=dflags}) env_down = return (dopt dflag dflags) -getDOptsTc :: TcM DynFlags +getDOptsTc :: NF_TcM DynFlags getDOptsTc (TcDown{tc_dflags=dflags}) env_down = return dflags \end{code} @@ -622,12 +613,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"), @@ -659,8 +645,8 @@ type InstLoc = (InstOrigin, SrcLoc, ErrCtxt) data InstOrigin = OccurrenceOf Id -- Occurrence of an overloaded identifier - | IPOcc Name -- Occurrence of an implicit parameter - | IPBind Name -- Binding site of an implicit parameter + | IPOcc (IPName Name) -- Occurrence of an implicit parameter + | IPBind (IPName Name) -- Binding site of an implicit parameter | RecordUpdOrigin @@ -668,7 +654,7 @@ data InstOrigin | InstanceDeclOrigin -- Typechecking an instance decl - | LiteralOrigin RenamedHsOverLit -- Occurrence of a literal + | LiteralOrigin HsOverLit -- Occurrence of a literal | PatOrigin RenamedPat @@ -717,12 +703,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)