Less Tc inside simplCore (Phase 1 for #14391)
authorArtem Pelenitsyn <a.pelenitsyn@gmail.com>
Tue, 15 May 2018 22:07:23 +0000 (18:07 -0400)
committerBen Gamari <ben@smart-cactus.org>
Tue, 15 May 2018 22:07:52 +0000 (18:07 -0400)
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

compiler/ghci/DebuggerUtils.hs
compiler/ghci/RtClosureInspect.hs
compiler/iface/IfaceEnv.hs
compiler/iface/LoadIface.hs
compiler/main/DynFlags.hs
compiler/main/HscTypes.hs
compiler/simplCore/CoreMonad.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcRnMonad.hs
testsuite/tests/ghc-api/T4891/T4891.hs

index f67e448..9af98c1 100644 (file)
@@ -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
 
index b85322d..d7e1267 100644 (file)
@@ -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
index 285bb28..00bcaa7 100644 (file)
@@ -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') }
index b9a7759..a380ccf 100644 (file)
@@ -25,6 +25,7 @@ module LoadIface (
         loadDecls,      -- Should move to TcIface and be renamed
         initExternalPackageState,
         moduleFreeHolesPrecise,
+        needWiredInHomeIface, loadWiredInHomeIface,
 
         pprModIfaceSimple,
         ifaceStats, pprModIface, showIface
index 25e99ee..0d49327 100644 (file)
@@ -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)
index 3087755..720aaf8 100644 (file)
@@ -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
index 107440a..a9be6c1 100644 (file)
@@ -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
index 0eec439..6a2f6ce 100644 (file)
@@ -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"
 
 {-
 ************************************************************************
index e93a2a5..d41f586 100644 (file)
@@ -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
index b2f8cc4..4aa4842 100644 (file)
@@ -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 ()