X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=f2d7791de06684ec847cc42e0b3f60856520fe14;hb=cbdeae8fc8a1c72d20d89241acae8a313214b51c;hp=b13a511f7e9c31230b6c8f50618a5c04b3b68c09;hpb=83eef621e4a4fbb6c1343304ec638cafd6c9dc09;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index b13a511..f2d7791 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -32,7 +32,7 @@ module TcMonad(
 
 	tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
 	tcAddErrCtxtM, tcSetErrCtxtM,
-	tcAddErrCtxt, tcSetErrCtxt,
+	tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
 
 	tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
 	tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
@@ -47,7 +47,8 @@ module TcMonad(
 
 import {-# SOURCE #-} TcEnv  ( TcEnv )
 
-import RnHsSyn		( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit )
+import HsSyn		( HsOverLit )
+import RnHsSyn		( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
 import Type		( Type, Kind, PredType, ThetaType, RhoType, TauType,
 			)
 import ErrUtils		( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
@@ -93,11 +94,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 +217,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 +250,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 +274,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
@@ -515,6 +524,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 +547,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 +610,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 +674,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 +728,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)