add -fsimpleopt-before-flatten

[ghc-hetmet.git] / compiler / iface / IfaceEnv.lhs

diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs
index 313424f..0e30f31 100644 (file)
--- a/compiler/iface/IfaceEnv.lhs
+++ b/compiler/iface/IfaceEnv.lhs
@@ -14,7 +14,7 @@ module IfaceEnv (
 
        -- Name-cache stuff
        allocateGlobalBinder, initNameCache, 
-        getNameCache, lockedUpdNameCache,
+        getNameCache, mkNameCacheUpdater, NameCacheUpdater
    ) where
 
 #include "HsVersions.h"
@@ -28,18 +28,18 @@ import Var
 import Name
 import PrelNames
 import Module
-import LazyUniqFM
+import UniqFM
 import FastString
 import UniqSupply
-import FiniteMap
 import BasicTypes
 import SrcLoc
 import MkId
 
 import Outputable
-import Exception     ( onException )
+import Exception     ( evaluate )
 
-import Control.Concurrent.MVar ( tryTakeMVar, takeMVar, putMVar )
+import Data.IORef    ( atomicModifyIORef, readIORef )
+import qualified Data.Map as Map
 \end{code}
 
 
@@ -98,8 +98,7 @@ allocateGlobalBinder name_supply mod occ loc
        -- Build a completely new Name, and put it in the cache
        Nothing -> (new_name_supply, name)
                where
-                 (us', us1)      = splitUniqSupply (nsUniqs name_supply)
-                 uniq            = uniqFromSupply us1
+                 (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)
                  name            = mkExternalName uniq mod occ loc
                  new_cache       = extendNameCache (nsNames name_supply) mod occ name
                  new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
@@ -159,14 +158,12 @@ lookupOrig mod occ
             case lookupOrigNameCache (nsNames name_cache) mod occ of {
              Just name -> (name_cache, name);
              Nothing   ->
-              let
-                us        = nsUniqs name_cache
-                uniq      = uniqFromSupply us
-                name      = mkExternalName uniq mod occ noSrcSpan
-                new_cache = extendNameCache (nsNames name_cache) mod occ name
-              in
-              case splitUniqSupply us of { (us',_) -> do
-                (name_cache{ nsUniqs = us', nsNames = new_cache }, name)
+              case takeUniqFromSupply (nsUniqs name_cache) of {
+              (uniq, us) ->
+                  let
+                    name      = mkExternalName uniq mod occ noSrcSpan
+                    new_cache = extendNameCache (nsNames name_cache) mod occ name
+                  in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)
     }}}
 
 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
@@ -176,14 +173,13 @@ newIPName occ_name_ip =
        ipcache = nsIPs name_cache
         key = occ_name_ip  -- Ensures that ?x and %x get distinct Names
     in
-    case lookupFM ipcache key of
+    case Map.lookup key ipcache of
       Just name_ip -> (name_cache, name_ip)
       Nothing      -> (new_ns, name_ip)
          where
-           (us', us1)  = splitUniqSupply (nsUniqs name_cache)
-           uniq        = uniqFromSupply us1
+           (uniq, us') = takeUniqFromSupply (nsUniqs name_cache)
            name_ip     = mapIPName (mkIPName uniq) occ_name_ip
-           new_ipcache = addToFM ipcache key name_ip
+           new_ipcache = Map.insert key name_ip ipcache
            new_ns      = name_cache {nsUniqs = us', nsIPs = new_ipcache}
 \end{code}
 
@@ -220,9 +216,9 @@ extendOrigNameCache nc name
 
 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 extendNameCache nc mod occ name
-  = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
+  = extendModuleEnvWith combine nc mod (unitOccEnv occ name)
   where
-    combine occ_env _ = extendOccEnv occ_env occ name
+    combine _ occ_env = extendOccEnv occ_env occ name
 
 getNameCache :: TcRnIf a b NameCache
 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; 
@@ -233,31 +229,19 @@ updNameCache upd_fn = do
   HscEnv { hsc_NC = nc_var } <- getTopEnv
   atomicUpdMutVar' nc_var upd_fn
 
--- | Update the name cache, but takes a lock while the update function is
--- running.  If the update function throws an exception the lock is released
--- and the exception propagated.
-lockedUpdNameCache :: (NameCache -> IO (NameCache, c)) -> TcRnIf a b c
-lockedUpdNameCache upd_fn = do
-  lock <- hsc_NC_lock `fmap` getTopEnv
-  -- Non-blocking "takeMVar" so we can show diagnostics if we didn't get the
-  -- lock.
-  mb_ok <- liftIO $ tryTakeMVar lock
-  case mb_ok of
-    Nothing -> do
-      traceIf (text "lockedUpdNameCache: failed to take lock.  blocking..")
-      _ <- liftIO $ takeMVar lock
-      traceIf (text "lockedUpdNameCache: got lock")
-    Just _ -> return ()
-
-  name_cache <- getNameCache
-  (name_cache', rslt) <- liftIO (upd_fn name_cache
-                                   `onException` putMVar lock ())
+-- | A function that atomically updates the name cache given a modifier
+-- function.  The second result of the modifier function will be the result
+-- of the IO action.
+type NameCacheUpdater c = (NameCache -> (NameCache, c)) -> IO c
 
+-- | Return a function to atomically update the name cache.
+mkNameCacheUpdater :: TcRnIf a b (NameCacheUpdater c)
+mkNameCacheUpdater = do
   nc_var <- hsc_NC `fmap` getTopEnv
-  writeMutVar nc_var $! name_cache'
-
-  liftIO (putMVar lock ())
-  return rslt
+  let update_nc f = do r <- atomicModifyIORef nc_var f
+                       _ <- evaluate =<< readIORef nc_var
+                       return r
+  return update_nc
 \end{code}
 
 
@@ -266,7 +250,7 @@ initNameCache :: UniqSupply -> [Name] -> NameCache
 initNameCache us names
   = NameCache { nsUniqs = us,
                nsNames = initOrigNames names,
-               nsIPs   = emptyFM }
+               nsIPs   = Map.empty }
 
 initOrigNames :: [Name] -> OrigNameCache
 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names