[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 b13a511..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,
-       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,9 +45,9 @@ 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,
@@ -93,11 +91,11 @@ 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 TcPredType  = PredType
-type TcThetaType = ThetaType
-type TcRhoType   = RhoType
-type TcTauType   = TauType
-type TcKind      = TcType
+type TcPredType     = PredType
+type TcThetaType    = ThetaType
+type TcRhoType      = RhoType
+type TcTauType      = TauType
+type TcKind         = TcType
 \end{code}
 
 
@@ -216,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
@@ -243,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!
 
@@ -267,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
@@ -289,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)
@@ -385,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
@@ -397,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
 
@@ -515,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}
 
 
@@ -535,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
@@ -598,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)
@@ -658,13 +679,16 @@ 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
+
   | RecordUpdOrigin
 
   | DataDeclOrigin             -- Typechecking a data declaration
 
   | InstanceDeclOrigin         -- Typechecking an instance decl
 
-  | LiteralOrigin RenamedHsOverLit     -- Occurrence of a literal
+  | LiteralOrigin HsOverLit    -- Occurrence of a literal
 
   | PatOrigin RenamedPat
 
@@ -709,12 +733,16 @@ pprInstLoc (orig, locn, ctxt)
   where
     pp_orig (OccurrenceOf id)
        = hsep [ptext SLIT("use of"), quotes (ppr id)]
+    pp_orig (IPOcc name)
+       = 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 (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")
+       =  ptext SLIT("the instance declaration")
     pp_orig (ArithSeqOrigin seq)
        = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
     pp_orig (SignatureOrigin)