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

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 386eae8..ad74133 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -114,8 +114,7 @@ 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_doc_hdr  = Nothing,
                 tcg_hpc      = False
 	     } ;
 	     lcl_env = TcLclEnv {
@@ -257,29 +256,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) }
@@ -491,26 +489,27 @@ addErrs msgs = mapM_ add msgs
 	     where
 	       add (loc,msg) = addErrAt loc msg
 
-addReport :: Message -> TcRn ()
-addReport msg = do loc <- getSrcSpanM; addReportAt loc msg
+addReport :: Message -> Message -> TcRn ()
+addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info
 
-addReportAt :: SrcSpan -> Message -> TcRn ()
-addReportAt loc msg
+addReportAt :: SrcSpan -> Message -> Message -> TcRn ()
+addReportAt loc msg extra_info
   = do { errs_var <- getErrsVar ;
 	 rdr_env <- getGlobalRdrEnv ;
          dflags <- getDOpts ;
-	 let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ;
+	 let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
+	                            msg extra_info } ;
 	 (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)
+addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty
 
 addLocWarn :: Located e -> (e -> Message) -> TcRn ()
-addLocWarn (L loc e) fn = addReportAt loc (fn e)
+addLocWarn (L loc e) fn = addReportAt loc (fn e) empty
 
 checkErr :: Bool -> Message -> TcRn ()
 -- Add the error if the bool is False
@@ -767,7 +766,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