module GHC.Driver.Env
( Hsc(..)
, HscEnv (..)
, hscUpdateFlags
, hscSetFlags
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
, hsc_HPT
, hsc_HUE
, hsc_HUG
, hsc_all_home_unit_ids
, hscUpdateLoggerFlags
, hscUpdateHUG
, hscUpdateHPT
, hscSetActiveHomeUnit
, hscSetActiveUnitId
, hscActiveUnitId
, runHsc
, runHsc'
, mkInteractiveHscEnv
, runInteractiveHsc
, hscEPS
, hscInterp
, hptCompleteSigs
, hptAllInstances
, hptInstancesBelow
, hptAnns
, hptAllThings
, hptSomeThingsBelowUs
, hptRules
, prepareAnnotations
, discardIC
, lookupType
, lookupIfaceByModule
, mainModIs
)
where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Errors ( printOrThrowDiagnostics )
import GHC.Driver.Errors.Types ( GhcMessage )
import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Config.Diagnostic (initDiagOpts)
import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )
import GHC.Runtime.Context
import GHC.Runtime.Interpreter.Types (Interp)
import GHC.Unit
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
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
import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )
import GHC.Types.CompleteMatch
import GHC.Types.Error ( emptyMessages, Messages )
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.Utils.Exception as Ex
import GHC.Utils.Outputable
import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Utils.Trace
import Data.IORef
import qualified Data.Set as Set
import Data.Set (Set)
import GHC.Unit.Module.Graph
import Data.List (sort)
import qualified Data.Map as Map
runHsc :: HscEnv -> Hsc a -> IO a
runHsc hsc_env (Hsc hsc) = do
(a, w) <- hsc hsc_env emptyMessages
let dflags = hsc_dflags hsc_env
let !diag_opts = initDiagOpts dflags
printOrThrowDiagnostics (hsc_logger hsc_env) diag_opts w
return a
runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
runHsc' hsc_env (Hsc hsc) = hsc hsc_env emptyMessages
mkInteractiveHscEnv :: HscEnv -> HscEnv
mkInteractiveHscEnv hsc_env =
let ic = hsc_IC hsc_env
in hscSetFlags (ic_dflags ic) $
hsc_env { hsc_plugins = ic_plugins ic }
runInteractiveHsc :: HscEnv -> Hsc a -> IO a
runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)
hsc_home_unit :: HscEnv -> HomeUnit
hsc_home_unit = unsafeGetHomeUnit . hsc_unit_env
hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_units . hsc_unit_env
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
hsc_HUE :: HscEnv -> HomeUnitEnv
hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env
hsc_HUG :: HscEnv -> HomeUnitGraph
hsc_HUG = ue_home_unit_graph . hsc_unit_env
hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId
hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG
hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHpt f (hsc_unit_env hsc_env) }
hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) }
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env)))
hptCompleteSigs :: HscEnv -> [CompleteMatch]
hptCompleteSigs = hptAllThings (md_complete_matches . hm_details)
hptAllInstances :: HscEnv -> (InstEnv, [FamInst])
hptAllInstances hsc_env
= let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do
let details = hm_details mod_info
return (md_insts details, md_fam_insts details)
in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)
hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> (InstEnv, [FamInst])
hptInstancesBelow hsc_env uid mnwib =
let
mn = gwib_mod mnwib
(insts, famInsts) =
unzip $ hptSomeThingsBelowUs (\mod_info ->
let details = hm_details mod_info
in if moduleName (mi_module (hm_iface mod_info)) == mn
then []
else [(md_insts details, md_fam_insts details)])
True
hsc_env
uid
mnwib
in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)
hptRules :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]
hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False
hptAnns :: HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation]
hptAnns hsc_env (Just (uid, mn)) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn
hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env
hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd)
(hugElts (hsc_HUG hsc_env))
hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
hptModulesBelow hsc_env uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below]
where
td_map = mgTransDeps (hsc_mod_graph hsc_env)
modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map
filtered_mods = Set.fromDistinctAscList . filter_mods . sort
filter_mods = \case
(r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs)
| m1 == m2 && uid1 == uid2 ->
let !r' = case b1 of
NotBoot -> r1
IsBoot -> r2
in r' : filter_mods rs
| otherwise -> r1 : filter_mods (r2:rs)
rs -> rs
hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
| isOneShot (ghcMode (hsc_dflags hsc_env)) = []
| otherwise
= let hug = hsc_HUG hsc_env
in
[ thing
|
(ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (hptModulesBelow hsc_env uid mn)
, include_hi_boot || (is_boot == NotBoot)
, mod /= moduleName gHC_PRIM
, not (mod == gwib_mod mn && uid == mod_uid)
, let things = case lookupHug hug mod_uid mod of
Just info -> extract info
Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg mempty
msg = vcat [text "missing module" <+> ppr mod,
text "When starting from" <+> ppr mn,
text "below:" <+> ppr (hptModulesBelow hsc_env uid mn),
text "Probable cause: out-of-date interface files"]
, thing <- things
]
prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
prepareAnnotations hsc_env mb_guts = do
eps <- hscEPS hsc_env
let
mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts
get_mod mg = (moduleUnitId (mg_module mg), GWIB (moduleName (mg_module mg)) NotBoot)
home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap get_mod mb_guts
other_pkg_anns = eps_ann_env eps
ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,
Just home_pkg_anns,
Just other_pkg_anns]
return ann_env
lookupType :: HscEnv -> Name -> IO (Maybe TyThing)
lookupType hsc_env name = do
eps <- liftIO $ hscEPS hsc_env
let pte = eps_PTE eps
hpt = hsc_HUG hsc_env
mod = assertPpr (isExternalName name) (ppr name) $
if isHoleName name
then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))
else nameModule name
!ty = if isOneShot (ghcMode (hsc_dflags hsc_env))
then lookupNameEnv pte name
else case lookupHugByModule mod hpt of
Just hm -> lookupNameEnv (md_types (hm_details hm)) name
Nothing -> lookupNameEnv pte name
pure ty
lookupIfaceByModule
:: HomeUnitGraph
-> PackageIfaceTable
-> Module
-> Maybe ModIface
lookupIfaceByModule hug pit mod
= case lookupHugByModule mod hug of
Just hm -> Just (hm_iface hm)
Nothing -> lookupModuleEnv pit mod
mainModIs :: HomeUnitEnv -> Module
mainModIs hue = mkHomeModule (expectJust "mainModIs" $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue))
hscInterp :: HscEnv -> Interp
hscInterp hsc_env = case hsc_interp hsc_env of
Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter")
Just i -> i
hscUpdateLoggerFlags :: HscEnv -> HscEnv
hscUpdateLoggerFlags h = h
{ hsc_logger = setLogFlags (hsc_logger h) (initLogFlags (hsc_dflags h)) }
hscUpdateFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags f h = hscSetFlags (f (hsc_dflags h)) h
hscSetFlags :: HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
hscSetFlags dflags h =
hscUpdateLoggerFlags $ h { hsc_dflags = dflags
, hsc_unit_env = ue_setFlags dflags (hsc_unit_env h) }
hscSetActiveHomeUnit :: HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit home_unit = hscSetActiveUnitId (homeUnitId home_unit)
hscSetActiveUnitId :: HasDebugCallStack => UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId uid e = e
{ hsc_unit_env = ue_setActiveUnit uid (hsc_unit_env e)
, hsc_dflags = ue_unitFlags uid (hsc_unit_env e) }
hscActiveUnitId :: HscEnv -> UnitId
hscActiveUnitId e = ue_currentUnit (hsc_unit_env e)
discardIC :: HscEnv -> HscEnv
discardIC hsc_env
= hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print
, ic_monad = new_ic_monad
, ic_plugins = old_plugins
} }
where
!new_ic_int_print = keep_external_name ic_int_print
!new_ic_monad = keep_external_name ic_monad
!old_plugins = ic_plugins old_ic
dflags = ic_dflags old_ic
old_ic = hsc_IC hsc_env
empty_ic = emptyInteractiveContext dflags
keep_external_name ic_name
| nameIsFromExternalPackage home_unit old_name = old_name
| otherwise = ic_name empty_ic
where
home_unit = hsc_home_unit hsc_env
old_name = ic_name old_ic