never executed always true always false
    1 {-# LANGUAGE LambdaCase #-}
    2 
    3 module GHC.Driver.Env
    4    ( Hsc(..)
    5    , HscEnv (..)
    6    , hscUpdateFlags
    7    , hscSetFlags
    8    , hsc_home_unit
    9    , hsc_units
   10    , hsc_HPT
   11    , hscUpdateHPT
   12    , hscUpdateLoggerFlags
   13    , runHsc
   14    , runHsc'
   15    , mkInteractiveHscEnv
   16    , runInteractiveHsc
   17    , hscEPS
   18    , hscInterp
   19    , hptCompleteSigs
   20    , hptAllInstances
   21    , hptInstancesBelow
   22    , hptAnns
   23    , hptAllThings
   24    , hptSomeThingsBelowUs
   25    , hptRules
   26    , prepareAnnotations
   27    , lookupType
   28    , lookupIfaceByModule
   29    , mainModIs
   30    )
   31 where
   32 
   33 import GHC.Prelude
   34 
   35 import GHC.Driver.Session
   36 import GHC.Driver.Errors ( printOrThrowDiagnostics )
   37 import GHC.Driver.Errors.Types ( GhcMessage )
   38 import GHC.Driver.Config.Logger (initLogFlags)
   39 import GHC.Driver.Config.Diagnostic (initDiagOpts)
   40 import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )
   41 
   42 import GHC.Runtime.Context
   43 import GHC.Runtime.Interpreter.Types (Interp)
   44 
   45 import GHC.Unit
   46 import GHC.Unit.Module.ModGuts
   47 import GHC.Unit.Module.ModIface
   48 import GHC.Unit.Module.ModDetails
   49 import GHC.Unit.Module.Deps
   50 import GHC.Unit.Home.ModInfo
   51 import GHC.Unit.Env
   52 import GHC.Unit.External
   53 
   54 import GHC.Core         ( CoreRule )
   55 import GHC.Core.FamInstEnv
   56 import GHC.Core.InstEnv ( ClsInst )
   57 
   58 import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )
   59 import GHC.Types.CompleteMatch
   60 import GHC.Types.Error ( emptyMessages, Messages )
   61 import GHC.Types.Name
   62 import GHC.Types.Name.Env
   63 import GHC.Types.TyThing
   64 
   65 import GHC.Builtin.Names ( gHC_PRIM )
   66 
   67 import GHC.Data.Maybe
   68 
   69 import GHC.Utils.Exception as Ex
   70 import GHC.Utils.Outputable
   71 import GHC.Utils.Monad
   72 import GHC.Utils.Panic
   73 import GHC.Utils.Misc
   74 import GHC.Utils.Logger
   75 import GHC.Utils.Trace
   76 
   77 import Data.IORef
   78 import qualified Data.Set as Set
   79 import Data.Set (Set)
   80 
   81 runHsc :: HscEnv -> Hsc a -> IO a
   82 runHsc hsc_env (Hsc hsc) = do
   83     (a, w) <- hsc hsc_env emptyMessages
   84     let dflags = hsc_dflags hsc_env
   85     let !diag_opts = initDiagOpts dflags
   86     printOrThrowDiagnostics (hsc_logger hsc_env) diag_opts w
   87     return a
   88 
   89 runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
   90 runHsc' hsc_env (Hsc hsc) = hsc hsc_env emptyMessages
   91 
   92 -- | Switches in the DynFlags and Plugins from the InteractiveContext
   93 mkInteractiveHscEnv :: HscEnv -> HscEnv
   94 mkInteractiveHscEnv hsc_env =
   95     let ic = hsc_IC hsc_env
   96     in hscSetFlags (ic_dflags ic) $
   97        hsc_env { hsc_plugins = ic_plugins ic }
   98 
   99 -- | A variant of runHsc that switches in the DynFlags and Plugins from the
  100 -- InteractiveContext before running the Hsc computation.
  101 runInteractiveHsc :: HscEnv -> Hsc a -> IO a
  102 runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)
  103 
  104 hsc_home_unit :: HscEnv -> HomeUnit
  105 hsc_home_unit = unsafeGetHomeUnit . hsc_unit_env
  106 
  107 hsc_units :: HscEnv -> UnitState
  108 hsc_units = ue_units . hsc_unit_env
  109 
  110 hsc_HPT :: HscEnv -> HomePackageTable
  111 hsc_HPT = ue_hpt . hsc_unit_env
  112 
  113 hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
  114 hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHpt f (hsc_unit_env hsc_env) }
  115 
  116 {-
  117 
  118 Note [Target code interpreter]
  119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  120 
  121 Template Haskell and GHCi use an interpreter to execute code that is built for
  122 the compiler target platform (= code host platform) on the compiler host
  123 platform (= code build platform).
  124 
  125 The internal interpreter can be used when both platforms are the same and when
  126 the built code is compatible with the compiler itself (same way, etc.). This
  127 interpreter is not always available: for instance stage1 compiler doesn't have
  128 it because there might be an ABI mismatch between the code objects (built by
  129 stage1 compiler) and the stage1 compiler itself (built by stage0 compiler).
  130 
  131 In most cases, an external interpreter can be used instead: it runs in a
  132 separate process and it communicates with the compiler via a two-way message
  133 passing channel. The process is lazily spawned to avoid overhead when it is not
  134 used.
  135 
  136 The target code interpreter to use can be selected per session via the
  137 `hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in
  138 which case Template Haskell and GHCi will fail to run. The interpreter to use is
  139 configured via command-line flags (in `GHC.setSessionDynFlags`).
  140 
  141 
  142 -}
  143 
  144 -- Note [hsc_type_env_var hack]
  145 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  146 -- hsc_type_env_var is used to initialize tcg_type_env_var, and
  147 -- eventually it is the mutable variable that is queried from
  148 -- if_rec_types to get a TypeEnv.  So, clearly, it's something
  149 -- related to knot-tying (see Note [Tying the knot]).
  150 -- hsc_type_env_var is used in two places: initTcRn (where
  151 -- it initializes tcg_type_env_var) and initIfaceCheck
  152 -- (where it initializes if_rec_types).
  153 --
  154 -- But why do we need a way to feed a mutable variable in?  Why
  155 -- can't we just initialize tcg_type_env_var when we start
  156 -- typechecking?  The problem is we need to knot-tie the
  157 -- EPS, and we may start adding things to the EPS before type
  158 -- checking starts.
  159 --
  160 -- Here is a concrete example. Suppose we are running
  161 -- "ghc -c A.hs", and we have this file system state:
  162 --
  163 --  A.hs-boot   A.hi-boot **up to date**
  164 --  B.hs        B.hi      **up to date**
  165 --  A.hs        A.hi      **stale**
  166 --
  167 -- The first thing we do is run checkOldIface on A.hi.
  168 -- checkOldIface will call loadInterface on B.hi so it can
  169 -- get its hands on the fingerprints, to find out if A.hi
  170 -- needs recompilation.  But loadInterface also populates
  171 -- the EPS!  And so if compilation turns out to be necessary,
  172 -- as it is in this case, the thunks we put into the EPS for
  173 -- B.hi need to have the correct if_rec_types mutable variable
  174 -- to query.
  175 --
  176 -- If the mutable variable is only allocated WHEN we start
  177 -- typechecking, then that's too late: we can't get the
  178 -- information to the thunks.  So we need to pre-commit
  179 -- to a type variable in 'hscIncrementalCompile' BEFORE we
  180 -- check the old interface.
  181 --
  182 -- This is all a massive hack because arguably checkOldIface
  183 -- should not populate the EPS. But that's a refactor for
  184 -- another day.
  185 
  186 -- | Retrieve the ExternalPackageState cache.
  187 hscEPS :: HscEnv -> IO ExternalPackageState
  188 hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env)))
  189 
  190 hptCompleteSigs :: HscEnv -> [CompleteMatch]
  191 hptCompleteSigs = hptAllThings  (md_complete_matches . hm_details)
  192 
  193 -- | Find all the instance declarations (of classes and families) from
  194 -- the Home Package Table filtered by the provided predicate function.
  195 -- Used in @tcRnImports@, to select the instances that are in the
  196 -- transitive closure of imports from the currently compiled module.
  197 hptAllInstances :: HscEnv -> ([ClsInst], [FamInst])
  198 hptAllInstances hsc_env
  199   = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do
  200                 let details = hm_details mod_info
  201                 return (md_insts details, md_fam_insts details)
  202     in (concat insts, concat famInsts)
  203 
  204 -- | Find instances visible from the given set of imports
  205 hptInstancesBelow :: HscEnv -> ModuleName -> Set ModuleNameWithIsBoot -> ([ClsInst], [FamInst])
  206 hptInstancesBelow hsc_env mn mns =
  207   let (insts, famInsts) =
  208         unzip $ hptSomeThingsBelowUs (\mod_info ->
  209                                      let details = hm_details mod_info
  210                                      -- Don't include instances for the current module
  211                                      in if moduleName (mi_module (hm_iface mod_info)) == mn
  212                                           then []
  213                                           else [(md_insts details, md_fam_insts details)])
  214                              True -- Include -hi-boot
  215                              hsc_env
  216                              mns
  217   in (concat insts, concat famInsts)
  218 
  219 -- | Get rules from modules "below" this one (in the dependency sense)
  220 hptRules :: HscEnv -> Set ModuleNameWithIsBoot -> [CoreRule]
  221 hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False
  222 
  223 
  224 -- | Get annotations from modules "below" this one (in the dependency sense)
  225 hptAnns :: HscEnv -> Maybe (Set ModuleNameWithIsBoot) -> [Annotation]
  226 hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps
  227 hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env
  228 
  229 hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
  230 hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env))
  231 
  232 -- | This function returns all the modules belonging to the home-unit that can
  233 -- be reached by following the given dependencies. Additionally, if both the
  234 -- boot module and the non-boot module can be reached, it only returns the
  235 -- non-boot one.
  236 hptModulesBelow :: HscEnv -> Set ModuleNameWithIsBoot -> Set ModuleNameWithIsBoot
  237 hptModulesBelow hsc_env mn = filtered_mods $ dep_mods mn Set.empty
  238   where
  239     !hpt = hsc_HPT hsc_env
  240 
  241     -- get all the dependent modules without filtering boot/non-boot
  242     dep_mods !deps !seen -- invariant: intersection of deps and seen is null
  243       | Set.null deps = seen
  244       | otherwise     = dep_mods deps' seen'
  245           where
  246             get_deps d@(GWIB mod _is_boot) (home_deps,all_deps) = case lookupHpt hpt mod of
  247               Nothing  -> (home_deps,all_deps) -- not a home-module
  248               Just hmi -> let
  249                             !home_deps' = Set.insert d home_deps
  250                             !all_deps'  = Set.union all_deps (dep_direct_mods (mi_deps (hm_iface hmi)))
  251                           in (home_deps', all_deps')
  252 
  253             -- all the non-transitive deps from our deps
  254             (seen',new_deps) = Set.foldr' get_deps (seen,Set.empty) deps
  255 
  256             -- maintain the invariant that deps haven't already been seen
  257             deps'    = Set.difference new_deps seen'
  258 
  259     -- remove boot modules when there is also a non-boot one
  260     filtered_mods mods = Set.fromDistinctAscList $ filter_mods $ Set.toAscList mods
  261 
  262     -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list
  263     -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a
  264     -- linear sweep with a window of size 2 to remove boot modules for which we
  265     -- have the corresponding non-boot.
  266     filter_mods = \case
  267       (r1@(GWIB m1 b1) : r2@(GWIB m2 _) : rs)
  268         | m1 == m2  -> let !r' = case b1 of
  269                                   NotBoot -> r1
  270                                   IsBoot  -> r2
  271                        in r' : filter_mods rs
  272         | otherwise -> r1 : filter_mods (r2:rs)
  273       rs -> rs
  274 
  275 
  276 
  277 -- | Get things from modules "below" this one (in the dependency sense)
  278 -- C.f Inst.hptInstances
  279 hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> Set ModuleNameWithIsBoot -> [a]
  280 hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
  281   | isOneShot (ghcMode (hsc_dflags hsc_env)) = []
  282 
  283   | otherwise
  284   = let hpt = hsc_HPT hsc_env
  285     in
  286     [ thing
  287     |   -- Find each non-hi-boot module below me
  288       GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- Set.toList (hptModulesBelow hsc_env deps)
  289     , include_hi_boot || (is_boot == NotBoot)
  290 
  291         -- unsavoury: when compiling the base package with --make, we
  292         -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't
  293         -- be in the HPT, because we never compile it; it's in the EPT
  294         -- instead. ToDo: clean up, and remove this slightly bogus filter:
  295     , mod /= moduleName gHC_PRIM
  296 
  297         -- Look it up in the HPT
  298     , let things = case lookupHpt hpt mod of
  299                     Just info -> extract info
  300                     Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg []
  301           msg = vcat [text "missing module" <+> ppr mod,
  302                       text "Probable cause: out-of-date interface files"]
  303                         -- This really shouldn't happen, but see #962
  304 
  305         -- And get its dfuns
  306     , thing <- things ]
  307 
  308 
  309 -- | Deal with gathering annotations in from all possible places
  310 --   and combining them into a single 'AnnEnv'
  311 prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
  312 prepareAnnotations hsc_env mb_guts = do
  313     eps <- hscEPS hsc_env
  314     let -- Extract annotations from the module being compiled if supplied one
  315         mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts
  316         -- Extract dependencies of the module if we are supplied one,
  317         -- otherwise load annotations from all home package table
  318         -- entries regardless of dependency ordering.
  319         home_pkg_anns  = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_direct_mods . mg_deps) mb_guts
  320         other_pkg_anns = eps_ann_env eps
  321         ann_env        = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,
  322                                                          Just home_pkg_anns,
  323                                                          Just other_pkg_anns]
  324     return ann_env
  325 
  326 -- | Find the 'TyThing' for the given 'Name' by using all the resources
  327 -- at our disposal: the compiled modules in the 'HomePackageTable' and the
  328 -- compiled modules in other packages that live in 'PackageTypeEnv'. Note
  329 -- that this does NOT look up the 'TyThing' in the module being compiled: you
  330 -- have to do that yourself, if desired
  331 lookupType :: HscEnv -> Name -> IO (Maybe TyThing)
  332 lookupType hsc_env name = do
  333    eps <- liftIO $ hscEPS hsc_env
  334    let pte = eps_PTE eps
  335        hpt = hsc_HPT hsc_env
  336 
  337        mod = assertPpr (isExternalName name) (ppr name) $
  338              if isHoleName name
  339                then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))
  340                else nameModule name
  341 
  342        !ty = if isOneShot (ghcMode (hsc_dflags hsc_env))
  343                -- in one-shot, we don't use the HPT
  344                then lookupNameEnv pte name
  345                else case lookupHptByModule hpt mod of
  346                 Just hm -> lookupNameEnv (md_types (hm_details hm)) name
  347                 Nothing -> lookupNameEnv pte name
  348    pure ty
  349 
  350 -- | Find the 'ModIface' for a 'Module', searching in both the loaded home
  351 -- and external package module information
  352 lookupIfaceByModule
  353         :: HomePackageTable
  354         -> PackageIfaceTable
  355         -> Module
  356         -> Maybe ModIface
  357 lookupIfaceByModule hpt pit mod
  358   = case lookupHptByModule hpt mod of
  359        Just hm -> Just (hm_iface hm)
  360        Nothing -> lookupModuleEnv pit mod
  361    -- If the module does come from the home package, why do we look in the PIT as well?
  362    -- (a) In OneShot mode, even home-package modules accumulate in the PIT
  363    -- (b) Even in Batch (--make) mode, there is *one* case where a home-package
  364    --     module is in the PIT, namely GHC.Prim when compiling the base package.
  365    -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package
  366    -- of its own, but it doesn't seem worth the bother.
  367 
  368 mainModIs :: HscEnv -> Module
  369 mainModIs hsc_env = mkHomeModule (hsc_home_unit hsc_env) (mainModuleNameIs (hsc_dflags hsc_env))
  370 
  371 -- | Retrieve the target code interpreter
  372 --
  373 -- Fails if no target code interpreter is available
  374 hscInterp :: HscEnv -> Interp
  375 hscInterp hsc_env = case hsc_interp hsc_env of
  376    Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter")
  377    Just i  -> i
  378 
  379 -- | Update the LogFlags of the Log in hsc_logger from the DynFlags in
  380 -- hsc_dflags. You need to call this when DynFlags are modified.
  381 hscUpdateLoggerFlags :: HscEnv -> HscEnv
  382 hscUpdateLoggerFlags h = h
  383   { hsc_logger = setLogFlags (hsc_logger h) (initLogFlags (hsc_dflags h)) }
  384 
  385 -- | Update Flags
  386 hscUpdateFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
  387 hscUpdateFlags f h = hscSetFlags (f (hsc_dflags h)) h
  388 
  389 -- | Set Flags
  390 hscSetFlags :: DynFlags -> HscEnv -> HscEnv
  391 hscSetFlags dflags h =
  392   -- update LogFlags from the new DynFlags
  393   hscUpdateLoggerFlags
  394   $ h { hsc_dflags = dflags }