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 }