Commit bb3fa2d1 authored by Artem Pelenitsyn's avatar Artem Pelenitsyn Committed by Ben Gamari

Less Tc inside simplCore (Phase 1 for #14391)

Simplifier depends on typechecker in two points: `thNameToGhcName`
(`lookupThName_maybe`, in particular)  and `lookupGlobal`. We want to
cut the ties in two steps.

1. (Presented in this commit), reimplement both functions in a way that
doesn't use typechecker.

2. (Should follow), do code moving: a) `lookupGlobal` should go in some
typechecker-free place; b) `thNameToGhcName` should leave simplifier,
because it is not used there at all (probably, it should be placed
somewhere where `GhcPlugins` can see it -- this is suggested by Joachim
on Trac).

Details
=======

We redesigned lookup interface a bit so that it exposes some
`IO`-equivalents of `Tc`-features in use.

First, `CoreMonad.hs` still calls `lookupGlobal` which is no longer
bound to the typechecker monad, but still resides in `TcEnv.hs` — it
should be moved out of Tc-land at some point (“Phase 2”) in the
future in order to achieve its part of the #14391's goal.

Second, `lookupThName_maybe` is eliminated from `CoreMonad.hs`
completely; this already achieves its part of the goal of #14391. Its
client, though, `thNameToGhcName`, is better to be moved in the future
also, for it is not used in the `CoreMonad.hs` (or anywhere else)
anyway. Joachim suggested “any module reexported by GhcPlugins (or
maybe even that module itself)”.

As a side goal, we removed `initTcForLookup` which was instrumental for
the past version of `lookupGlobal`. This, in turn, called for pushing
some more parts of the lookup interface from the `Tc`-monad to `IO`,
most notably, adding `IO`-version of `lookupOrig` and pushing
`dataConInfoPtrToName` to `IO`. The `lookupOrig` part, in turn,
triggered a slight redesign of name cache updating interface: we now
have both, `updNameCacheIO` and `updNameCacheTc`, both accepting `mod`
and `occ` to force them inside, instead of more error-prone outside
before. But all these hardly have to do anything with #14391, mere
refactoring.

Reviewers: simonpj, nomeata, bgamari, hvr

Reviewed By: simonpj, bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14391

Differential Revision: https://phabricator.haskell.org/D4503
parent bb338f2e
......@@ -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
......
......@@ -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
......
......@@ -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') }
......
......@@ -25,6 +25,7 @@ module LoadIface (
loadDecls, -- Should move to TcIface and be renamed
initExternalPackageState,
moduleFreeHolesPrecise,
needWiredInHomeIface, loadWiredInHomeIface,
pprModIfaceSimple,
ifaceStats, pprModIface, showIface
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......@@ -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"
{-
************************************************************************
......
......@@ -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
......
......@@ -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 ()
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment