[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 3e3322e..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,14 +45,14 @@ 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, 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 )
@@ -93,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
@@ -217,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
@@ -244,7 +247,7 @@ which is a Royal Pain.  By the time this fork stuff is used they'll
 have been unified down so there won't be any kind variables, but we
 can't express that in the current typechecker framework.
 
-So we compromise and use unsafeInterleaveSST.
+So we compromise and use unsafeInterleaveIO.
 
 We throw away any error messages!
 
@@ -268,7 +271,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 +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)
@@ -386,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
@@ -398,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
 
@@ -516,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}
 
 
@@ -536,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
@@ -599,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)
@@ -668,7 +688,7 @@ data InstOrigin
 
   | InstanceDeclOrigin         -- Typechecking an instance decl
 
-  | LiteralOrigin RenamedHsOverLit     -- Occurrence of a literal
+  | LiteralOrigin HsOverLit    -- Occurrence of a literal
 
   | PatOrigin RenamedPat
 
@@ -722,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)