X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=f4b9131f4a0d566f5253a5ab0a55d523f8babe0a;hp=386eae8bf3f0707f20a4f79d3179548c0b95f655;hb=46c673a70fe14fe05d7160b456925b8591b5f779;hpb=aa0c0de94e25aa64139688f8e4c4ba51ddca6f54

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 386eae8..f4b9131 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -114,9 +114,9 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
 		tcg_fords    = [],
 		tcg_dfun_n   = dfun_n_var,
 		tcg_keep     = keep_var,
-		tcg_doc      = Nothing,
-		tcg_hmi      = HaddockModInfo Nothing Nothing Nothing Nothing,
-                tcg_hpc      = False
+		tcg_doc_hdr  = Nothing,
+                tcg_hpc      = False,
+                tcg_main     = Nothing
 	     } ;
 	     lcl_env = TcLclEnv {
 		tcl_errs       = errs_var,
@@ -257,29 +257,28 @@ getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
 getEps :: TcRnIf gbl lcl ExternalPackageState
 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
 
--- Updating the EPS.  This should be an atomic operation.
--- Note the delicate 'seq' which forces the EPS before putting it in the
--- variable.  Otherwise what happens is that we get
---	write eps_var (....(unsafeRead eps_var)....)
--- and if the .... is strict, that's obviously bottom.  By forcing it beforehand
--- we make the unsafeRead happen before we update the variable.
-
+-- | Update the external package state.  Returns the second result of the
+-- modifier function.
+--
+-- This is an atomic operation and forces evaluation of the modified EPS in
+-- order to avoid space leaks.
 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
 	  -> TcRnIf gbl lcl a
-updateEps upd_fn = do	{ traceIf (text "updating EPS")
-			; eps_var <- getEpsVar
-			; eps <- readMutVar eps_var
-			; let { (eps', val) = upd_fn eps }
-			; seq eps' (writeMutVar eps_var eps')
-			; return val }
+updateEps upd_fn = do
+  traceIf (text "updating EPS")
+  eps_var <- getEpsVar
+  atomicUpdMutVar' eps_var upd_fn
 
+-- | Update the external package state.
+--
+-- This is an atomic operation and forces evaluation of the modified EPS in
+-- order to avoid space leaks.
 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
 	   -> TcRnIf gbl lcl ()
-updateEps_ upd_fn = do	{ traceIf (text "updating EPS_")
-			; eps_var <- getEpsVar
-			; eps <- readMutVar eps_var
-			; let { eps' = upd_fn eps }
-			; seq eps' (writeMutVar eps_var eps') }
+updateEps_ upd_fn = do
+  traceIf (text "updating EPS_")
+  eps_var <- getEpsVar
+  atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
 
 getHpt :: TcRnIf gbl lcl HomePackageTable
 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
@@ -456,6 +455,7 @@ wrapLocSndM fn (L loc a) =
     return (b, L loc c)
 \end{code}
 
+Reporting errors
 
 \begin{code}
 getErrsVar :: TcRn (TcRef Messages)
@@ -470,47 +470,25 @@ addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
 failWith :: Message -> TcRn a
 failWith msg = addErr msg >> failM
 
-addLocErr :: Located e -> (e -> Message) -> TcRn ()
-addLocErr (L loc e) fn = addErrAt loc (fn e)
-
 addErrAt :: SrcSpan -> Message -> TcRn ()
-addErrAt loc msg = addLongErrAt loc msg empty
-
-addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
-addLongErrAt loc msg extra
-  = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;	
-	 errs_var <- getErrsVar ;
-	 rdr_env <- getGlobalRdrEnv ;
-         dflags <- getDOpts ;
-	 let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
-	 (warns, errs) <- readMutVar errs_var ;
-  	 writeMutVar errs_var (warns, errs `snocBag` err) }
+-- addErrAt is mainly (exclusively?) used by the renamer, where
+-- tidying is not an issue, but it's all lazy so the extra
+-- work doesn't matter
+addErrAt loc msg = do { ctxt <- getErrCtxt 
+	     	      ; tidy_env <- tcInitTidyEnv
+                      ; err_info <- mkErrInfo tidy_env ctxt
+	              ; addLongErrAt loc msg err_info }
 
 addErrs :: [(SrcSpan,Message)] -> TcRn ()
 addErrs msgs = mapM_ add msgs
 	     where
 	       add (loc,msg) = addErrAt loc msg
 
-addReport :: Message -> TcRn ()
-addReport msg = do loc <- getSrcSpanM; addReportAt loc msg
-
-addReportAt :: SrcSpan -> Message -> TcRn ()
-addReportAt loc msg
-  = do { errs_var <- getErrsVar ;
-	 rdr_env <- getGlobalRdrEnv ;
-         dflags <- getDOpts ;
-	 let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ;
-	 (warns, errs) <- readMutVar errs_var ;
-  	 writeMutVar errs_var (warns `snocBag` warn, errs) }
-
 addWarn :: Message -> TcRn ()
-addWarn msg = addReport (ptext (sLit "Warning:") <+> msg)
+addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty
 
 addWarnAt :: SrcSpan -> Message -> TcRn ()
-addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg)
-
-addLocWarn :: Located e -> (e -> Message) -> TcRn ()
-addLocWarn (L loc e) fn = addReportAt loc (fn e)
+addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty
 
 checkErr :: Bool -> Message -> TcRn ()
 -- Add the error if the bool is False
@@ -543,6 +521,38 @@ discardWarnings thing_inside
 \end{code}
 
 
+%************************************************************************
+%*									*
+	Shared error message stuff: renamer and typechecker
+%*									*
+%************************************************************************
+
+\begin{code}
+addReport :: Message -> Message -> TcRn ()
+addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info
+
+addReportAt :: SrcSpan -> Message -> Message -> TcRn ()
+addReportAt loc msg extra_info
+  = do { errs_var <- getErrsVar ;
+	 rdr_env <- getGlobalRdrEnv ;
+         dflags <- getDOpts ;
+	 let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
+	                            msg extra_info } ;
+	 (warns, errs) <- readMutVar errs_var ;
+  	 writeMutVar errs_var (warns `snocBag` warn, errs) }
+
+addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
+addLongErrAt loc msg extra
+  = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;	
+	 errs_var <- getErrsVar ;
+	 rdr_env <- getGlobalRdrEnv ;
+         dflags <- getDOpts ;
+	 let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
+	 (warns, errs) <- readMutVar errs_var ;
+  	 writeMutVar errs_var (warns, errs `snocBag` err) }
+\end{code}
+
+
 \begin{code}
 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
 -- Does try_m, with a debug-trace on failure
@@ -675,8 +685,7 @@ failIfErrsM = ifErrsM failM (return ())
 
 %************************************************************************
 %*									*
-	Context management and error message generation
-	  	    for the type checker
+	Context management for the type checker
 %*									*
 %************************************************************************
 
@@ -721,6 +730,12 @@ setInstCtxt (InstLoc _ src_loc ctxt) thing_inside
   = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
 \end{code}
 
+%************************************************************************
+%*									*
+	     Error message generation (type checker)
+%*									*
+%************************************************************************
+
     The addErrTc functions add an error message, but do not cause failure.
     The 'M' variants pass a TidyEnv that has already been used to
     tidy up the message; we then use it to tidy the context messages
@@ -767,7 +782,7 @@ addWarnTcM :: (TidyEnv, Message) -> TcM ()
 addWarnTcM (env0, msg)
  = do { ctxt <- getErrCtxt ;
 	err_info <- mkErrInfo env0 ctxt ;
-	addReport (vcat [ptext (sLit "Warning:") <+> msg, err_info]) }
+	addReport (ptext (sLit "Warning:") <+> msg) err_info }
 
 warnTc :: Bool -> Message -> TcM ()
 warnTc warn_if_true warn_msg