diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs
index f67e44860e0de4272aa7e93c8a58d6caae9c6930..9af98c1bcfdc66c2f9df101cf3f1480acd260476 100644
--- a/compiler/ghci/DebuggerUtils.hs
+++ b/compiler/ghci/DebuggerUtils.hs
@@ -9,9 +9,8 @@ import GhcPrelude
import GHCi.InfoTable
import CmmInfo ( stdInfoTableSizeB )
import DynFlags
+import HscTypes
import FastString
-import TcRnTypes
-import TcRnMonad
import IfaceEnv
import Module
import OccName
@@ -35,21 +34,20 @@ import Data.List
-- We use this string to lookup the interpreter's internal representation of the name
-- using the lookupOrig.
--
-dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
-dataConInfoPtrToName x = do
- dflags <- getDynFlags
- theString <- liftIO $ do
- let ptr = castPtr x :: Ptr StgInfoTable
- conDescAddress <- getConDescAddress dflags ptr
- peekArray0 0 conDescAddress
+dataConInfoPtrToName :: HscEnv -> Ptr () -> IO Name
+dataConInfoPtrToName hsc_env x = do
+ let dflags = hsc_dflags hsc_env
+ theString <- do
+ let ptr = castPtr x :: Ptr StgInfoTable
+ conDescAddress <- getConDescAddress dflags ptr
+ peekArray0 0 conDescAddress
let (pkg, mod, occ) = parse theString
pkgFS = mkFastStringByteList pkg
modFS = mkFastStringByteList mod
occFS = mkFastStringByteList occ
occName = mkOccNameFS OccName.dataName occFS
modName = mkModule (fsToUnitId pkgFS) (mkModuleNameFS modFS)
- return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName)
- `recoverM` (Right `fmap` lookupOrig modName occName)
+ lookupOrigIO hsc_env modName occName
where
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index b85322d60e88b3c681fd754237620dc07b3f7b5d..d7e1267d979bf4e782baa2d07a6c476cd49eb7b6 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -750,8 +750,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
if monomorphic
then parens (text "already monomorphic: " <> ppr my_ty)
else Ppr.empty)
- Right dcname <- dataConInfoPtrToName (infoPtr clos)
- (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
+ dcname <- liftIO $ dataConInfoPtrToName hsc_env (infoPtr clos)
+ (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
case mb_dc of
Nothing -> do -- This can happen for private constructors compiled -O0
-- where the .hi descriptor does not export them
@@ -923,9 +923,9 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
return [(tv', contents)]
Constr -> do
- Right dcname <- dataConInfoPtrToName (infoPtr clos)
+ dcname <- liftIO $ dataConInfoPtrToName hsc_env (infoPtr clos)
traceTR (text "Constr1" <+> ppr dcname)
- (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
+ (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
case mb_dc of
Nothing-> do
forM (elems $ ptrs clos) $ \a -> do
diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs
index 285bb2899cb74a0673b96dd5fcc08211cf1d7fd9..00bcaa77f107606431522ebadfac986dbe15e784 100644
--- a/compiler/iface/IfaceEnv.hs
+++ b/compiler/iface/IfaceEnv.hs
@@ -6,7 +6,7 @@ module IfaceEnv (
newGlobalBinder, newInteractiveBinder,
externaliseName,
lookupIfaceTop,
- lookupOrig, lookupOrigNameCache, extendNameCache,
+ lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,
newIfaceName, newIfaceNames,
extendIfaceIdEnv, extendIfaceTyVarEnv,
tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
@@ -16,7 +16,7 @@ module IfaceEnv (
ifaceExportNames,
-- Name-cache stuff
- allocateGlobalBinder, updNameCache,
+ allocateGlobalBinder, updNameCacheTc,
mkNameCacheUpdater, NameCacheUpdater(..),
) where
@@ -61,8 +61,7 @@ newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
-- moment when we know its Module and SrcLoc in their full glory
newGlobalBinder mod occ loc
- = do { mod `seq` occ `seq` return () -- See notes with lookupOrig
- ; name <- updNameCache $ \name_cache ->
+ = do { name <- updNameCacheTc mod occ $ \name_cache ->
allocateGlobalBinder name_cache mod occ loc
; traceIf (text "newGlobalBinder" <+>
(vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))
@@ -73,7 +72,7 @@ newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
-- from the interactive context
newInteractiveBinder hsc_env occ loc
= do { let mod = icInteractiveModule (hsc_IC hsc_env)
- ; updNameCacheIO hsc_env $ \name_cache ->
+ ; updNameCacheIO hsc_env mod occ $ \name_cache ->
allocateGlobalBinder name_cache mod occ loc }
allocateGlobalBinder
@@ -130,11 +129,30 @@ newtype NameCacheUpdater
mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
mkNameCacheUpdater = do { hsc_env <- getTopEnv
- ; return (NCU (updNameCacheIO hsc_env)) }
+ ; return (NCU (updNameCache hsc_env)) }
+
+updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))
+ -> TcRnIf a b c
+updNameCacheTc mod occ upd_fn = do {
+ hsc_env <- getTopEnv
+ ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }
+
+
+updNameCacheIO :: HscEnv -> Module -> OccName
+ -> (NameCache -> (NameCache, c))
+ -> IO c
+updNameCacheIO hsc_env mod occ upd_fn = do {
+
+ -- First ensure that mod and occ are evaluated
+ -- If not, chaos can ensue:
+ -- we read the name-cache
+ -- then pull on mod (say)
+ -- which does some stuff that modifies the name cache
+ -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
+
+ mod `seq` occ `seq` return ()
+ ; updNameCache hsc_env upd_fn }
-updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c
-updNameCache upd_fn = do { hsc_env <- getTopEnv
- ; liftIO $ updNameCacheIO hsc_env upd_fn }
{-
************************************************************************
@@ -149,26 +167,31 @@ updNameCache upd_fn = do { hsc_env <- getTopEnv
-- and 'Module' is simply that of the 'ModIface' you are typechecking.
lookupOrig :: Module -> OccName -> TcRnIf a b Name
lookupOrig mod occ
- = do { -- First ensure that mod and occ are evaluated
- -- If not, chaos can ensue:
- -- we read the name-cache
- -- then pull on mod (say)
- -- which does some stuff that modifies the name cache
- -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
- mod `seq` occ `seq` return ()
- ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
-
- ; 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)
- }}}
+ = do { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
+
+ ; updNameCacheTc mod occ $ lookupNameCache mod occ }
+
+lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
+lookupOrigIO hsc_env mod occ
+ = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ
+
+lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
+-- Lookup up the (Module,OccName) in the NameCache
+-- If you find it, return it; if not, allocate a fresh original name and extend
+-- the NameCache.
+-- Reason: this may the first occurrence of (say) Foo.bar we have encountered.
+-- If we need to explore its value we will load Foo.hi; but meanwhile all we
+-- need is a Name for it.
+lookupNameCache mod occ 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) }}
externaliseName :: Module -> Name -> TcRnIf m n Name
-- Take an Internal Name and make it an External one,
@@ -178,7 +201,7 @@ externaliseName mod name
loc = nameSrcSpan name
uniq = nameUnique name
; occ `seq` return () -- c.f. seq in newGlobalBinder
- ; updNameCache $ \ ns ->
+ ; updNameCacheTc mod occ $ \ ns ->
let name' = mkExternalName uniq mod occ loc
ns' = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }
in (ns', name') }
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index b9a77598dafef6b44083a67e6e2bc3969b72e057..a380ccf0084393de8fcdb47e3c8dd2df29482f2a 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -25,6 +25,7 @@ module LoadIface (
loadDecls, -- Should move to TcIface and be renamed
initExternalPackageState,
moduleFreeHolesPrecise,
+ needWiredInHomeIface, loadWiredInHomeIface,
pprModIfaceSimple,
ifaceStats, pprModIface, showIface
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 25e99eee05460f3e68d6c5a2117e3442d869e865..0d49327f47323c3127fcbd72d087943f4c6ec951 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -114,6 +114,7 @@ module DynFlags (
setUnitId,
interpretPackageEnv,
canonicalizeHomeModule,
+ canonicalizeModuleIfHome,
-- ** Parsing DynFlags
parseDynamicFlagsCmdLine,
@@ -4861,6 +4862,12 @@ canonicalizeHomeModule dflags mod_name =
Nothing -> mkModule (thisPackage dflags) mod_name
Just mod -> mod
+canonicalizeModuleIfHome :: DynFlags -> Module -> Module
+canonicalizeModuleIfHome dflags mod
+ = if thisPackage dflags == moduleUnitId mod
+ then canonicalizeHomeModule dflags (moduleName mod)
+ else mod
+
-- -----------------------------------------------------------------------------
-- | Find the package environment (if one exists)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 30877555ff8c0c75dc4d7f9acf3b5a91307c617c..720aaf8b9bfb77da6a420cb781973f3c1de7e976 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -106,7 +106,7 @@ module HscTypes (
-- * Information on imports and exports
WhetherHasOrphans, IsBootInterface, Usage(..),
Dependencies(..), noDependencies,
- updNameCacheIO,
+ updNameCache,
IfaceExport,
-- * Warnings
@@ -2612,10 +2612,10 @@ interface file); so we give it 'noSrcLoc' then. Later, when we find
its binding site, we fix it up.
-}
-updNameCacheIO :: HscEnv
- -> (NameCache -> (NameCache, c)) -- The updating function
- -> IO c
-updNameCacheIO hsc_env upd_fn
+updNameCache :: HscEnv
+ -> (NameCache -> (NameCache, c)) -- The updating function
+ -> IO c
+updNameCache hsc_env upd_fn
= atomicModifyIORef' (hsc_NC hsc_env) upd_fn
mkSOName :: Platform -> FilePath -> FilePath
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index 107440a7680de404b3558309c567ce77377acdfb..a9be6c1f50072a6b7b0a40d7624ab6e4bd03e705 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -55,8 +55,9 @@ module CoreMonad (
import GhcPrelude hiding ( read )
-import Name( Name )
-import TcRnMonad ( initTcForLookup )
+import Convert
+import RdrName
+import Name
import CoreSyn
import HscTypes
import Module
@@ -81,6 +82,7 @@ import Data.List
import Data.Ord
import Data.Dynamic
import Data.IORef
+import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Map.Strict as MapStrict
@@ -88,7 +90,6 @@ import Data.Word
import Control.Monad
import Control.Applicative ( Alternative(..) )
-import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
import qualified Language.Haskell.TH as TH
{-
@@ -811,6 +812,17 @@ instance MonadThings CoreM where
-- to names in the module being compiled, if possible. Exact TH names
-- will be bound to the name they represent, exactly.
thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
-thNameToGhcName th_name = do
- hsc_env <- getHscEnv
- liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
+thNameToGhcName th_name
+ = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
+ -- Pick the first that works
+ -- E.g. reify (mkName "A") will pick the class A in preference
+ -- to the data constructor A
+ ; return (listToMaybe names) }
+ where
+ lookup rdr_name
+ | Just n <- isExact_maybe rdr_name -- This happens in derived code
+ = return $ if isExternalName n then Just n else Nothing
+ | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+ = do { cache <- getOrigNameCache
+ ; return $ lookupOrigNameCache cache rdr_mod rdr_occ }
+ | otherwise = return Nothing
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 0eec439b8c8c000becb4ae6e6e54fe09b2a29a9d..6a2f6ce2435423a2c32c4795a241f8c8109f26d7 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -23,7 +23,7 @@ module TcEnv(
tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass, tcLookupAxiom,
- lookupGlobal,
+ lookupGlobal, ioLookupDataCon,
-- Local environment
tcExtendKindEnv, tcExtendKindEnvList,
@@ -106,13 +106,14 @@ import Outputable
import Encoding
import FastString
import ListSetOps
+import ErrUtils
import Util
import Maybes( MaybeErr(..), orElse )
import qualified GHC.LanguageExtensions as LangExt
import Data.IORef
import Data.List
-
+import Control.Monad
{- *********************************************************************
* *
@@ -121,14 +122,69 @@ import Data.List
********************************************************************* -}
lookupGlobal :: HscEnv -> Name -> IO TyThing
--- An IO version, used outside the typechecker
--- It's more complicated than it looks, because it may
--- need to suck in an interface file
+-- A variant of lookupGlobal_maybe for the clients which are not
+-- interested in recovering from lookup failure and accept panic.
lookupGlobal hsc_env name
- = initTcForLookup hsc_env (tcLookupGlobal name)
- -- This initTcForLookup stuff is massive overkill
- -- but that's how it is right now, and at least
- -- this function localises it
+ = do {
+ mb_thing <- lookupGlobal_maybe hsc_env name
+ ; case mb_thing of
+ Succeeded thing -> return thing
+ Failed msg -> pprPanic "lookupGlobal" msg
+ }
+
+lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+-- This may look up an Id that one one has previously looked up.
+-- If so, we are going to read its interface file, and add its bindings
+-- to the ExternalPackageTable.
+lookupGlobal_maybe hsc_env name
+ = do { -- Try local envt
+ let mod = icInteractiveModule (hsc_IC hsc_env)
+ dflags = hsc_dflags hsc_env
+ tcg_semantic_mod = canonicalizeModuleIfHome dflags mod
+
+ ; if nameIsLocalOrFrom tcg_semantic_mod name
+ then (return
+ (Failed (text "Can't find local name: " <+> ppr name)))
+ -- Internal names can happen in GHCi
+ else
+ -- Try home package table and external package table
+ lookupImported_maybe hsc_env name
+ }
+
+lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+-- Returns (Failed err) if we can't find the interface file for the thing
+lookupImported_maybe hsc_env name
+ = do { mb_thing <- lookupTypeHscEnv hsc_env name
+ ; case mb_thing of
+ Just thing -> return (Succeeded thing)
+ Nothing -> importDecl_maybe hsc_env name
+ }
+
+importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+importDecl_maybe hsc_env name
+ | Just thing <- wiredInNameTyThing_maybe name
+ = do { when (needWiredInHomeIface thing)
+ (initIfaceLoad hsc_env (loadWiredInHomeIface name))
+ -- See Note [Loading instances for wired-in things]
+ ; return (Succeeded thing) }
+ | otherwise
+ = initIfaceLoad hsc_env (importDecl name)
+
+ioLookupDataCon :: HscEnv -> Name -> IO DataCon
+ioLookupDataCon hsc_env name = do
+ mb_thing <- ioLookupDataCon_maybe hsc_env name
+ case mb_thing of
+ Succeeded thing -> return thing
+ Failed msg -> pprPanic "lookupDataConIO" msg
+
+ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon)
+ioLookupDataCon_maybe hsc_env name = do
+ thing <- lookupGlobal hsc_env name
+ return $ case thing of
+ AConLike (RealDataCon con) -> Succeeded con
+ _ -> Failed $
+ pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>
+ text "used as a data constructor"
{-
************************************************************************
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index e93a2a5e5c0d9677d8ebcb08ca597b34e1619d8a..d41f586ffe452c0a2c958e3f42a66a02a9e86821 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -10,7 +10,7 @@ Functions for working with the typechecker environment (setters, getters...).
module TcRnMonad(
-- * Initalisation
- initTc, initTcWithGbl, initTcInteractive, initTcForLookup, initTcRnIf,
+ initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
-- * Simple accessors
discardResult,
@@ -177,7 +177,6 @@ import CostCentreState
import qualified GHC.LanguageExtensions as LangExt
-import Control.Exception
import Data.IORef
import Control.Monad
import Data.Set ( Set )
@@ -249,9 +248,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
tcg_mod = mod,
tcg_semantic_mod =
- if thisPackage dflags == moduleUnitId mod
- then canonicalizeHomeModule dflags (moduleName mod)
- else mod,
+ canonicalizeModuleIfHome dflags mod,
tcg_src = hsc_src,
tcg_rdr_env = emptyGlobalRdrEnv,
tcg_fix_env = emptyNameEnv,
@@ -376,15 +373,6 @@ initTcInteractive hsc_env thing_inside
where
interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
-initTcForLookup :: HscEnv -> TcM a -> IO a
--- The thing_inside is just going to look up something
--- in the environment, so we don't need much setup
-initTcForLookup hsc_env thing_inside
- = do { (msgs, m) <- initTcInteractive hsc_env thing_inside
- ; case m of
- Nothing -> throwIO $ mkSrcErr $ snd msgs
- Just x -> return x }
-
{- Note [Default types]
~~~~~~~~~~~~~~~~~~~~~~~
The Integer type is simply not available in package ghc-prim (it is
diff --git a/testsuite/tests/ghc-api/T4891/T4891.hs b/testsuite/tests/ghc-api/T4891/T4891.hs
index b2f8cc464de85937aeaf38ae7e355bfb23cc6a82..4aa4842640c4407f23bc8de1cfca8263e394c24b 100644
--- a/testsuite/tests/ghc-api/T4891/T4891.hs
+++ b/testsuite/tests/ghc-api/T4891/T4891.hs
@@ -54,13 +54,10 @@ chaseConstructor !hv = do
case tipe closure of
Indirection _ -> chaseConstructor (ptrs closure ! 0)
Constr -> do
- withSession $ \hscEnv -> liftIO $ initTcForLookup hscEnv $ do
- eDcname <- dataConInfoPtrToName (infoPtr closure)
- case eDcname of
- Left _ -> return ()
- Right dcName -> do
- liftIO $ putStrLn $ "Name: " ++ showPpr dflags dcName
- liftIO $ putStrLn $ "OccString: " ++ "'" ++ getOccString dcName ++ "'"
- dc <- tcLookupDataCon dcName
- liftIO $ putStrLn $ "DataCon: " ++ showPpr dflags dc
+ withSession $ \hscEnv -> liftIO $ do
+ dcName <- dataConInfoPtrToName hscEnv (infoPtr closure)
+ putStrLn $ "Name: " ++ showPpr dflags dcName
+ putStrLn $ "OccString: " ++ "'" ++ getOccString dcName ++ "'"
+ dc <- ioLookupDataCon hscEnv dcName
+ putStrLn $ "DataCon: " ++ showPpr dflags dc
_ -> return ()