Make access to NameCache atomic. Sometimes needs a lock.

[ghc-hetmet.git] / compiler / main / HscMain.lhs

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 34e4593..fec3f6c 100644 (file)
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -112,10 +112,11 @@ import LazyUniqFM         ( emptyUFM )
 import UniqSupply       ( initUs_ )
 import Bag             ( unitBag )
 import Exception
-import MonadUtils
+-- import MonadUtils
 
 import Control.Monad
-import System.IO
+import Control.Concurrent.MVar ( newMVar )
+-- import System.IO
 import Data.IORef
 \end{code}
 #include "HsVersions.h"
@@ -133,6 +134,7 @@ newHscEnv callbacks dflags
   = do         { eps_var <- newIORef initExternalPackageState
        ; us      <- mkSplitUniqSupply 'r'
        ; nc_var  <- newIORef (initNameCache us knownKeyNames)
+        ; nc_lock <- newMVar ()
        ; fc_var  <- newIORef emptyUFM
        ; mlc_var <- newIORef emptyModuleEnv
         ; optFuel <- initOptFuelState
@@ -144,6 +146,7 @@ newHscEnv callbacks dflags
                           hsc_HPT     = emptyHomePackageTable,
                           hsc_EPS     = eps_var,
                           hsc_NC      = nc_var,
+                          hsc_NC_lock = nc_lock,
                           hsc_FC      = fc_var,
                           hsc_MLC     = mlc_var,
                           hsc_OptFuel = optFuel,
@@ -229,12 +232,13 @@ hscTypecheckRename mod_summary rdr_module = do
           <- {-# SCC "Typecheck-Rename" #-}
              ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
 
-    let rn_info = do decl <- tcg_rn_decls tc_result
-                     imports <- tcg_rn_imports tc_result
-                     let exports = tcg_rn_exports tc_result
-                     let doc = tcg_doc tc_result
-                    let hmi = tcg_hmi tc_result
-                     return (decl,imports,exports,doc,hmi)
+    let -- This 'do' is in the Maybe monad!
+        rn_info = do { decl <- tcg_rn_decls tc_result
+                     ; let imports = tcg_rn_imports tc_result
+                           exports = tcg_rn_exports tc_result
+                           doc            = tcg_doc tc_result
+                          hmi     = tcg_hmi tc_result
+                     ; return (decl,imports,exports,doc,hmi) }
 
     return (tc_result, rn_info)