CoreMonad: add lookupOrigCoreM, modeled after IfaceEnv.lookupOrig

[ghc-hetmet.git] / compiler / simplCore / CoreMonad.lhs

diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 6ddcff2..67a0991 100644 (file)
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -43,6 +43,8 @@ module CoreMonad (
     debugTraceMsg, debugTraceMsgS,
     dumpIfSet_dyn, 
 
+    lookupOrigCoreM,
+
 #ifdef GHCI
     -- * Getting 'Name's
     thNameToGhcName
@@ -90,6 +92,11 @@ import Data.Word
 import Control.Monad
 
 import Prelude hiding   ( read )
+import OccName
+import IfaceEnv
+import Name
+import SrcLoc
+import Control.Exception.Base
 
 #ifdef GHCI
 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
@@ -1121,3 +1128,29 @@ thNameToGhcName th_name = do
     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
 #endif
 \end{code}
+
+\begin{code}
+updNameCache' :: (NameCache -> (NameCache, a)) -> CoreM a
+updNameCache' upd_fn = do
+  HscEnv { hsc_NC = nc_var } <- getHscEnv
+  r  <- liftIO $ atomicModifyIORef nc_var upd_fn
+  r' <- liftIO $ readIORef nc_var
+  _  <- liftIO $ evaluate r'
+  return r
+
+-- cut-and-pasted from IfaceEnv, where it lives in the TcRn monad rather than CoreM
+lookupOrigCoreM :: Module -> OccName -> CoreM Name
+lookupOrigCoreM mod occ
+  = do         { mod `seq` occ `seq` return () 
+        ; updNameCache' $ \name_cache ->
+            case lookupOrigNameCache (nsNames name_cache) mod occ of {
+             Just name -> (name_cache, name);
+             Nothing   ->
+              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)
+    }}}
+\end{code}
\ No newline at end of file