[project @ 2001-10-23 22:25:46 by sof]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcMonad.lhs

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index d9fb249..41f0890 100644 (file)
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -1,9 +1,7 @@
 \begin{code}
 module TcMonad(
-       TcType, 
-       TcTauType, TcPredType, TcThetaType, TcRhoType,
-       TcTyVar, TcTyVarSet, TcClassContext,
-       TcKind,
+       TcType, TcTauType, TcPredType, TcThetaType, TcRhoType,
+       TcTyVar, TcTyVarSet, TcKind,
 
        TcM, NF_TcM, TcDown, TcEnv, 
 
@@ -32,7 +30,7 @@ module TcMonad(
 
        tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
        tcAddErrCtxtM, tcSetErrCtxtM,
-       tcAddErrCtxt, tcSetErrCtxt,
+       tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
 
        tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
        tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
@@ -47,15 +45,14 @@ module TcMonad(
 
 import {-# SOURCE #-} TcEnv  ( TcEnv )
 
-import HsSyn           ( HsOverLit )
+import HsLit           ( HsOverLit )
 import RnHsSyn         ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
-import Type            ( Type, Kind, PredType, ThetaType, RhoType, TauType,
-                       )
+import TcType          ( Type, Kind, PredType, ThetaType, TauType, RhoType )
 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 VarEnv          ( TidyEnv, emptyTidyEnv )
@@ -94,7 +91,6 @@ type TcType = Type            -- A TcType can have mutable type variables
        -- 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
@@ -218,6 +214,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
@@ -293,7 +295,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)
@@ -389,6 +391,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
@@ -401,7 +405,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
 
@@ -519,6 +529,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}
 
 
@@ -539,11 +552,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
@@ -602,6 +615,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)
@@ -725,7 +742,7 @@ pprInstLoc (orig, locn, ctxt)
     pp_orig (PatOrigin pat)
        = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
     pp_orig (InstanceDeclOrigin)
-       =  ptext SLIT("an instance declaration")
+       =  ptext SLIT("the instance declaration")
     pp_orig (ArithSeqOrigin seq)
        = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
     pp_orig (SignatureOrigin)