{-# LANGUAGE CPP #-}

module GHC.Driver.Env
   ( Hsc(..)
   , HscEnv (..)
   , hsc_home_unit
   , hsc_units
   , runHsc
   , mkInteractiveHscEnv
   , runInteractiveHsc
   , hscEPS
   , hptCompleteSigs
   , hptInstances
   , hptAnns
   , hptAllThings
   , hptSomeThingsBelowUs
   , hptRules
   , prepareAnnotations
   , lookupType
   , lookupIfaceByModule
   , mainModIs
   )
where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Driver.Ppr
import GHC.Driver.Session
import GHC.Driver.Errors ( printOrThrowWarnings )

import GHC.Runtime.Context
import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )

import GHC.Unit
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Deps
import GHC.Unit.Home.ModInfo
import GHC.Unit.Env
import GHC.Unit.External

import GHC.Core         ( CoreRule )
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv ( ClsInst )

import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )
import GHC.Types.CompleteMatch
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.TyThing

import GHC.Builtin.Names ( gHC_PRIM )

import GHC.Data.Maybe
import GHC.Data.Bag

import GHC.Utils.Outputable
import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Misc

import Control.Monad    ( guard )
import Data.IORef

runHsc :: HscEnv -> Hsc a -> IO a
runHsc :: forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc HscEnv -> WarningMessages -> IO (a, WarningMessages)
hsc) = do
    (a
a, WarningMessages
w) <- HscEnv -> WarningMessages -> IO (a, WarningMessages)
hsc HscEnv
hsc_env forall a. Bag a
emptyBag
    Logger -> DynFlags -> WarningMessages -> IO ()
printOrThrowWarnings (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) WarningMessages
w
    forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Switches in the DynFlags and Plugins from the InteractiveContext
mkInteractiveHscEnv :: HscEnv -> HscEnv
mkInteractiveHscEnv :: HscEnv -> HscEnv
mkInteractiveHscEnv HscEnv
hsc_env =
    let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
    in HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags  = InteractiveContext -> DynFlags
ic_dflags  InteractiveContext
ic
               , hsc_plugins :: [LoadedPlugin]
hsc_plugins = InteractiveContext -> [LoadedPlugin]
ic_plugins InteractiveContext
ic
               }

-- | A variant of runHsc that switches in the DynFlags and Plugins from the
-- InteractiveContext before running the Hsc computation.
runInteractiveHsc :: HscEnv -> Hsc a -> IO a
runInteractiveHsc :: forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env = forall a. HscEnv -> Hsc a -> IO a
runHsc (HscEnv -> HscEnv
mkInteractiveHscEnv HscEnv
hsc_env)

hsc_home_unit :: HscEnv -> HomeUnit
hsc_home_unit :: HscEnv -> HomeUnit
hsc_home_unit = UnitEnv -> HomeUnit
ue_home_unit forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env

hsc_units :: HscEnv -> UnitState
hsc_units :: HscEnv -> UnitState
hsc_units = UnitEnv -> UnitState
ue_units forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitEnv
hsc_unit_env

{-

Note [Target code interpreter]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Template Haskell and GHCi use an interpreter to execute code that is built for
the compiler target platform (= code host platform) on the compiler host
platform (= code build platform).

The internal interpreter can be used when both platforms are the same and when
the built code is compatible with the compiler itself (same way, etc.). This
interpreter is not always available: for instance stage1 compiler doesn't have
it because there might be an ABI mismatch between the code objects (built by
stage1 compiler) and the stage1 compiler itself (built by stage0 compiler).

In most cases, an external interpreter can be used instead: it runs in a
separate process and it communicates with the compiler via a two-way message
passing channel. The process is lazily spawned to avoid overhead when it is not
used.

The target code interpreter to use can be selected per session via the
`hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in
which case Template Haskell and GHCi will fail to run. The interpreter to use is
configured via command-line flags (in `GHC.setSessionDynFlags`).


-}

-- Note [hsc_type_env_var hack]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- hsc_type_env_var is used to initialize tcg_type_env_var, and
-- eventually it is the mutable variable that is queried from
-- if_rec_types to get a TypeEnv.  So, clearly, it's something
-- related to knot-tying (see Note [Tying the knot]).
-- hsc_type_env_var is used in two places: initTcRn (where
-- it initializes tcg_type_env_var) and initIfaceCheck
-- (where it initializes if_rec_types).
--
-- But why do we need a way to feed a mutable variable in?  Why
-- can't we just initialize tcg_type_env_var when we start
-- typechecking?  The problem is we need to knot-tie the
-- EPS, and we may start adding things to the EPS before type
-- checking starts.
--
-- Here is a concrete example. Suppose we are running
-- "ghc -c A.hs", and we have this file system state:
--
--  A.hs-boot   A.hi-boot **up to date**
--  B.hs        B.hi      **up to date**
--  A.hs        A.hi      **stale**
--
-- The first thing we do is run checkOldIface on A.hi.
-- checkOldIface will call loadInterface on B.hi so it can
-- get its hands on the fingerprints, to find out if A.hi
-- needs recompilation.  But loadInterface also populates
-- the EPS!  And so if compilation turns out to be necessary,
-- as it is in this case, the thunks we put into the EPS for
-- B.hi need to have the correct if_rec_types mutable variable
-- to query.
--
-- If the mutable variable is only allocated WHEN we start
-- typechecking, then that's too late: we can't get the
-- information to the thunks.  So we need to pre-commit
-- to a type variable in 'hscIncrementalCompile' BEFORE we
-- check the old interface.
--
-- This is all a massive hack because arguably checkOldIface
-- should not populate the EPS. But that's a refactor for
-- another day.

-- | Retrieve the ExternalPackageState cache.
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env = forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hsc_env)

hptCompleteSigs :: HscEnv -> [CompleteMatch]
hptCompleteSigs :: HscEnv -> [CompleteMatch]
hptCompleteSigs = forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings  (ModDetails -> [CompleteMatch]
md_complete_matches forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details)

-- | Find all the instance declarations (of classes and families) from
-- the Home Package Table filtered by the provided predicate function.
-- Used in @tcRnImports@, to select the instances that are in the
-- transitive closure of imports from the currently compiled module.
hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])
hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])
hptInstances HscEnv
hsc_env ModuleName -> Bool
want_this_module
  = let ([[ClsInst]]
insts, [[FamInst]]
famInsts) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ \HomeModInfo
mod_info -> do
                forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ModuleName -> Bool
want_this_module (forall unit. GenModule unit -> ModuleName
moduleName (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
mod_info))))
                let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
mod_info
                forall (m :: * -> *) a. Monad m => a -> m a
return (ModDetails -> [ClsInst]
md_insts ModDetails
details, ModDetails -> [FamInst]
md_fam_insts ModDetails
details)
    in (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ClsInst]]
insts, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
famInsts)

-- | Get rules from modules "below" this one (in the dependency sense)
hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]
hptRules = forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs (ModDetails -> [CoreRule]
md_rules forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details) Bool
False


-- | Get annotations from modules "below" this one (in the dependency sense)
hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]
hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]
hptAnns HscEnv
hsc_env (Just [ModuleNameWithIsBoot]
deps) = forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs (ModDetails -> [Annotation]
md_anns forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details) Bool
False HscEnv
hsc_env [ModuleNameWithIsBoot]
deps
hptAnns HscEnv
hsc_env Maybe [ModuleNameWithIsBoot]
Nothing = forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings (ModDetails -> [Annotation]
md_anns forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details) HscEnv
hsc_env

hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings :: forall a. (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings HomeModInfo -> [a]
extract HscEnv
hsc_env = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HomeModInfo -> [a]
extract (HomePackageTable -> [HomeModInfo]
eltsHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env))

-- | Get things from modules "below" this one (in the dependency sense)
-- C.f Inst.hptInstances
hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs :: forall a.
(HomeModInfo -> [a])
-> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]
hptSomeThingsBelowUs HomeModInfo -> [a]
extract Bool
include_hi_boot HscEnv
hsc_env [ModuleNameWithIsBoot]
deps
  | GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) = []

  | Bool
otherwise
  = let hpt :: HomePackageTable
hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
    in
    [ a
thing
    |   -- Find each non-hi-boot module below me
      GWIB { gwib_mod :: forall mod. GenWithIsBoot mod -> mod
gwib_mod = ModuleName
mod, gwib_isBoot :: forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot = IsBootInterface
is_boot } <- [ModuleNameWithIsBoot]
deps
    , Bool
include_hi_boot Bool -> Bool -> Bool
|| (IsBootInterface
is_boot forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot)

        -- unsavoury: when compiling the base package with --make, we
        -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't
        -- be in the HPT, because we never compile it; it's in the EPT
        -- instead. ToDo: clean up, and remove this slightly bogus filter:
    , ModuleName
mod forall a. Eq a => a -> a -> Bool
/= forall unit. GenModule unit -> ModuleName
moduleName Module
gHC_PRIM

        -- Look it up in the HPT
    , let things :: [a]
things = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt ModuleName
mod of
                    Just HomeModInfo
info -> HomeModInfo -> [a]
extract HomeModInfo
info
                    Maybe HomeModInfo
Nothing -> forall a. String -> SDoc -> a -> a
pprTrace String
"WARNING in hptSomeThingsBelowUs" SDoc
msg []
          msg :: SDoc
msg = [SDoc] -> SDoc
vcat [String -> SDoc
text String
"missing module" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
mod,
                      String -> SDoc
text String
"Probable cause: out-of-date interface files"]
                        -- This really shouldn't happen, but see #962

        -- And get its dfuns
    , a
thing <- [a]
things ]


-- | Deal with gathering annotations in from all possible places
--   and combining them into a single 'AnnEnv'
prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
prepareAnnotations HscEnv
hsc_env Maybe ModGuts
mb_guts = do
    ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
    let -- Extract annotations from the module being compiled if supplied one
        mb_this_module_anns :: Maybe AnnEnv
mb_this_module_anns = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Annotation] -> AnnEnv
mkAnnEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> [Annotation]
mg_anns) Maybe ModGuts
mb_guts
        -- Extract dependencies of the module if we are supplied one,
        -- otherwise load annotations from all home package table
        -- entries regardless of dependency ordering.
        home_pkg_anns :: AnnEnv
home_pkg_anns  = ([Annotation] -> AnnEnv
mkAnnEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]
hptAnns HscEnv
hsc_env) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dependencies -> [ModuleNameWithIsBoot]
dep_mods forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> Dependencies
mg_deps) Maybe ModGuts
mb_guts
        other_pkg_anns :: AnnEnv
other_pkg_anns = ExternalPackageState -> AnnEnv
eps_ann_env ExternalPackageState
eps
        ann_env :: AnnEnv
ann_env        = forall a. (a -> a -> a) -> [a] -> a
foldl1' AnnEnv -> AnnEnv -> AnnEnv
plusAnnEnv forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe AnnEnv
mb_this_module_anns,
                                                         forall a. a -> Maybe a
Just AnnEnv
home_pkg_anns,
                                                         forall a. a -> Maybe a
Just AnnEnv
other_pkg_anns]
    forall (m :: * -> *) a. Monad m => a -> m a
return AnnEnv
ann_env

-- | Find the 'TyThing' for the given 'Name' by using all the resources
-- at our disposal: the compiled modules in the 'HomePackageTable' and the
-- compiled modules in other packages that live in 'PackageTypeEnv'. Note
-- that this does NOT look up the 'TyThing' in the module being compiled: you
-- have to do that yourself, if desired
lookupType :: HscEnv -> Name -> IO (Maybe TyThing)
lookupType :: HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
name = do
   ExternalPackageState
eps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hsc_env)
   let pte :: PackageTypeEnv
pte = ExternalPackageState -> PackageTypeEnv
eps_PTE ExternalPackageState
eps
       hpt :: HomePackageTable
hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env

       mod :: Module
mod = ASSERT2( isExternalName name, ppr name )
             if Name -> Bool
isHoleName Name
name
               then HomeUnit -> ModuleName -> Module
mkHomeModule (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) (forall unit. GenModule unit -> ModuleName
moduleName (HasDebugCallStack => Name -> Module
nameModule Name
name))
               else HasDebugCallStack => Name -> Module
nameModule Name
name

       !ty :: Maybe TyThing
ty = if GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
               -- in one-shot, we don't use the HPT
               then forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv PackageTypeEnv
pte Name
name
               else case HomePackageTable -> Module -> Maybe HomeModInfo
lookupHptByModule HomePackageTable
hpt Module
mod of
                Just HomeModInfo
hm -> forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (ModDetails -> PackageTypeEnv
md_types (HomeModInfo -> ModDetails
hm_details HomeModInfo
hm)) Name
name
                Maybe HomeModInfo
Nothing -> forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv PackageTypeEnv
pte Name
name
   forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TyThing
ty

-- | Find the 'ModIface' for a 'Module', searching in both the loaded home
-- and external package module information
lookupIfaceByModule
        :: HomePackageTable
        -> PackageIfaceTable
        -> Module
        -> Maybe ModIface
lookupIfaceByModule :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomePackageTable
hpt PackageIfaceTable
pit Module
mod
  = case HomePackageTable -> Module -> Maybe HomeModInfo
lookupHptByModule HomePackageTable
hpt Module
mod of
       Just HomeModInfo
hm -> forall a. a -> Maybe a
Just (HomeModInfo -> ModIface
hm_iface HomeModInfo
hm)
       Maybe HomeModInfo
Nothing -> forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv PackageIfaceTable
pit Module
mod
   -- If the module does come from the home package, why do we look in the PIT as well?
   -- (a) In OneShot mode, even home-package modules accumulate in the PIT
   -- (b) Even in Batch (--make) mode, there is *one* case where a home-package
   --     module is in the PIT, namely GHC.Prim when compiling the base package.
   -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package
   -- of its own, but it doesn't seem worth the bother.

mainModIs :: HscEnv -> Module
mainModIs :: HscEnv -> Module
mainModIs HscEnv
hsc_env = HomeUnit -> ModuleName -> Module
mkHomeModule (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) (DynFlags -> ModuleName
mainModuleNameIs (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))