never executed always true always false
1
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE NondecreasingIndentation #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE TypeFamilies #-}
6
7
8 -- | This is the driver for the 'ghc --backpack' mode, which
9 -- is a reimplementation of the "package manager" bits of
10 -- Backpack directly in GHC. The basic method of operation
11 -- is to compile packages and then directly insert them into
12 -- GHC's in memory database.
13 --
14 -- The compilation products of this mode aren't really suitable
15 -- for Cabal, because GHC makes up component IDs for the things
16 -- it builds and doesn't serialize out the database contents.
17 -- But it's still handy for constructing tests.
18
19 module GHC.Driver.Backpack (doBackpack) where
20
21 import GHC.Prelude
22
23 -- In a separate module because it hooks into the parser.
24 import GHC.Driver.Backpack.Syntax
25 import GHC.Driver.Config.Finder (initFinderOpts)
26 import GHC.Driver.Config.Parser (initParserOpts)
27 import GHC.Driver.Config.Diagnostic
28 import GHC.Driver.Monad
29 import GHC.Driver.Session
30 import GHC.Driver.Ppr
31 import GHC.Driver.Main
32 import GHC.Driver.Make
33 import GHC.Driver.Env
34 import GHC.Driver.Errors
35 import GHC.Driver.Errors.Types
36
37 import GHC.Parser
38 import GHC.Parser.Header
39 import GHC.Parser.Lexer
40 import GHC.Parser.Annotation
41
42 import GHC.Rename.Names
43
44 import GHC hiding (Failed, Succeeded)
45 import GHC.Tc.Utils.Monad
46 import GHC.Iface.Recomp
47 import GHC.Builtin.Names
48
49 import GHC.Types.SrcLoc
50 import GHC.Types.SourceError
51 import GHC.Types.SourceFile
52 import GHC.Types.Unique.FM
53 import GHC.Types.Unique.DFM
54 import GHC.Types.Unique.DSet
55
56 import GHC.Utils.Outputable
57 import GHC.Utils.Fingerprint
58 import GHC.Utils.Misc
59 import GHC.Utils.Panic
60 import GHC.Utils.Error
61 import GHC.Utils.Logger
62
63 import GHC.Unit
64 import GHC.Unit.Env
65 import GHC.Unit.External
66 import GHC.Unit.Finder
67 import GHC.Unit.Module.Graph
68 import GHC.Unit.Module.ModSummary
69 import GHC.Unit.Home.ModInfo
70
71 import GHC.Linker.Types
72
73 import qualified GHC.LanguageExtensions as LangExt
74
75 import GHC.Data.Maybe
76 import GHC.Data.StringBuffer
77 import GHC.Data.FastString
78 import qualified GHC.Data.EnumSet as EnumSet
79 import qualified GHC.Data.ShortText as ST
80
81 import Data.List ( partition )
82 import System.Exit
83 import Control.Monad
84 import System.FilePath
85 import Data.Version
86
87 -- for the unification
88 import Data.IORef
89 import Data.Map (Map)
90 import qualified Data.Map as Map
91 import qualified Data.Set as Set
92
93 -- | Entry point to compile a Backpack file.
94 doBackpack :: [FilePath] -> Ghc ()
95 doBackpack [src_filename] = do
96 -- Apply options from file to dflags
97 dflags0 <- getDynFlags
98 let dflags1 = dflags0
99 let parser_opts1 = initParserOpts dflags1
100 src_opts <- liftIO $ getOptionsFromFile parser_opts1 src_filename
101 (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
102 modifySession (hscSetFlags dflags)
103 logger <- getLogger -- Get the logger after having set the session flags,
104 -- so that logger options are correctly set.
105 -- Not doing so caused #20396.
106 -- Cribbed from: preprocessFile / GHC.Driver.Pipeline
107 liftIO $ checkProcessArgsResult unhandled_flags
108 liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns
109 -- TODO: Preprocessing not implemented
110
111 buf <- liftIO $ hGetStringBuffer src_filename
112 let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
113 case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of
114 PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)
115 POk _ pkgname_bkp -> do
116 -- OK, so we have an LHsUnit PackageName, but we want an
117 -- LHsUnit HsComponentId. So let's rename it.
118 hsc_env <- getSession
119 let bkp = renameHsUnits (hsc_units hsc_env) (bkpPackageNameMap pkgname_bkp) pkgname_bkp
120 initBkpM src_filename bkp $
121 forM_ (zip [1..] bkp) $ \(i, lunit) -> do
122 let comp_name = unLoc (hsunitName (unLoc lunit))
123 msgTopPackage (i,length bkp) comp_name
124 innerBkpM $ do
125 let (cid, insts) = computeUnitId lunit
126 if null insts
127 then if cid == UnitId (fsLit "main")
128 then compileExe lunit
129 else compileUnit cid []
130 else typecheckUnit cid insts
131 doBackpack _ =
132 throwGhcException (CmdLineError "--backpack can only process a single file")
133
134 computeUnitId :: LHsUnit HsComponentId -> (UnitId, [(ModuleName, Module)])
135 computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
136 where
137 cid = hsComponentId (unLoc (hsunitName unit))
138 reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
139 get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname
140 get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet
141 get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet
142 get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =
143 unitFreeModuleHoles (convertHsComponentId hsuid)
144
145 -- | Tiny enum for all types of Backpack operations we may do.
146 data SessionType
147 -- | A compilation operation which will result in a
148 -- runnable executable being produced.
149 = ExeSession
150 -- | A type-checking operation which produces only
151 -- interface files, no object files.
152 | TcSession
153 -- | A compilation operation which produces both
154 -- interface files and object files.
155 | CompSession
156 deriving (Eq)
157
158 -- | Create a temporary Session to do some sort of type checking or
159 -- compilation.
160 withBkpSession :: UnitId
161 -> [(ModuleName, Module)]
162 -> [(Unit, ModRenaming)]
163 -> SessionType -- what kind of session are we doing
164 -> BkpM a -- actual action to run
165 -> BkpM a
166 withBkpSession cid insts deps session_type do_this = do
167 dflags <- getDynFlags
168 let cid_fs = unitFS cid
169 is_primary = False
170 uid_str = unpackFS (mkInstantiatedUnitHash cid insts)
171 cid_str = unpackFS cid_fs
172 -- There are multiple units in a single Backpack file, so we
173 -- need to separate out the results in those cases. Right now,
174 -- we follow this hierarchy:
175 -- $outputdir/$compid --> typecheck results
176 -- $outputdir/$compid/$unitid --> compile results
177 key_base p | Just f <- p dflags = f
178 | otherwise = "."
179 sub_comp p | is_primary = p
180 | otherwise = p </> cid_str
181 outdir p | CompSession <- session_type
182 -- Special case when package is definite
183 , not (null insts) = sub_comp (key_base p) </> uid_str
184 | otherwise = sub_comp (key_base p)
185
186 mk_temp_env hsc_env = hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env
187 mk_temp_dflags unit_state dflags = dflags
188 { backend = case session_type of
189 TcSession -> NoBackend
190 _ -> backend dflags
191 , ghcLink = case session_type of
192 TcSession -> NoLink
193 _ -> ghcLink dflags
194 , homeUnitInstantiations_ = insts
195 -- if we don't have any instantiation, don't
196 -- fill `homeUnitInstanceOfId` as it makes no
197 -- sense (we're not instantiating anything)
198 , homeUnitInstanceOf_ = if null insts then Nothing else Just cid
199 , homeUnitId_ = case session_type of
200 TcSession -> newUnitId cid Nothing
201 -- No hash passed if no instances
202 _ | null insts -> newUnitId cid Nothing
203 | otherwise -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts))
204
205
206 -- If we're type-checking an indefinite package, we want to
207 -- turn on interface writing. However, if the user also
208 -- explicitly passed in `-fno-code`, we DON'T want to write
209 -- interfaces unless the user also asked for `-fwrite-interface`.
210 -- See Note [-fno-code mode]
211 , generalFlags = case session_type of
212 -- Make sure to write interfaces when we are type-checking
213 -- indefinite packages.
214 TcSession
215 | backend dflags /= NoBackend
216 -> EnumSet.insert Opt_WriteInterface (generalFlags dflags)
217 _ -> generalFlags dflags
218
219 -- Setup all of the output directories according to our hierarchy
220 , objectDir = Just (outdir objectDir)
221 , hiDir = Just (outdir hiDir)
222 , stubDir = Just (outdir stubDir)
223 -- Unset output-file for non exe builds
224 , outputFile_ = case session_type of
225 ExeSession -> outputFile_ dflags
226 _ -> Nothing
227 , dynOutputFile_ = case session_type of
228 ExeSession -> dynOutputFile_ dflags
229 _ -> Nothing
230 -- Clear the import path so we don't accidentally grab anything
231 , importPaths = []
232 -- Synthesize the flags
233 , packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
234 let uid = unwireUnit unit_state
235 $ improveUnit unit_state
236 $ renameHoleUnit unit_state (listToUFM insts) uid0
237 in ExposePackage
238 (showSDoc dflags
239 (text "-unit-id" <+> ppr uid <+> ppr rn))
240 (UnitIdArg uid) rn) deps
241 }
242 withTempSession mk_temp_env $ do
243 dflags <- getSessionDynFlags
244 -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
245 setSessionDynFlags dflags -- calls initUnits
246 do_this
247
248 withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a
249 withBkpExeSession deps do_this =
250 withBkpSession (UnitId (fsLit "main")) [] deps ExeSession do_this
251
252 getSource :: UnitId -> BkpM (LHsUnit HsComponentId)
253 getSource cid = do
254 bkp_env <- getBkpEnv
255 case Map.lookup cid (bkp_table bkp_env) of
256 Nothing -> pprPanic "missing needed dependency" (ppr cid)
257 Just lunit -> return lunit
258
259 typecheckUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()
260 typecheckUnit cid insts = do
261 lunit <- getSource cid
262 buildUnit TcSession cid insts lunit
263
264 compileUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()
265 compileUnit cid insts = do
266 -- Let everyone know we're building this unit
267 msgUnitId (mkVirtUnit cid insts)
268 lunit <- getSource cid
269 buildUnit CompSession cid insts lunit
270
271 -- | Compute the dependencies with instantiations of a syntactic
272 -- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a
273 -- unit file, return the 'Unit' corresponding to @p[A=<A>]@.
274 -- The @include_sigs@ parameter controls whether or not we also
275 -- include @dependency signature@ declarations in this calculation.
276 --
277 -- Invariant: this NEVER returns UnitId.
278 hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(Unit, ModRenaming)]
279 hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)
280 where
281 get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))
282 | include_sigs || not is_sig = [(convertHsComponentId hsuid, go mb_lrn)]
283 | otherwise = []
284 where
285 go Nothing = ModRenaming True []
286 go (Just lrns) = ModRenaming False (map convRn lrns)
287 where
288 convRn (L _ (Renaming (L _ from) Nothing)) = (from, from)
289 convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)
290 get_dep _ = []
291
292 buildUnit :: SessionType -> UnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
293 buildUnit session cid insts lunit = do
294 -- NB: include signature dependencies ONLY when typechecking.
295 -- If we're compiling, it's not necessary to recursively
296 -- compile a signature since it isn't going to produce
297 -- any object files.
298 let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)
299 raw_deps = map fst deps_w_rns
300 hsc_env <- getSession
301 -- The compilation dependencies are just the appropriately filled
302 -- in unit IDs which must be compiled before we can compile.
303 let hsubst = listToUFM insts
304 deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps
305
306 -- Build dependencies OR make sure they make sense. BUT NOTE,
307 -- we can only check the ones that are fully filled; the rest
308 -- we have to defer until we've typechecked our local signature.
309 -- TODO: work this into GHC.Driver.Make!!
310 forM_ (zip [1..] deps0) $ \(i, dep) ->
311 case session of
312 TcSession -> return ()
313 _ -> compileInclude (length deps0) (i, dep)
314
315 -- IMPROVE IT
316 let deps = map (improveUnit (hsc_units hsc_env)) deps0
317
318 mb_old_eps <- case session of
319 TcSession -> fmap Just getEpsGhc
320 _ -> return Nothing
321
322 conf <- withBkpSession cid insts deps_w_rns session $ do
323
324 dflags <- getDynFlags
325 mod_graph <- hsunitModuleGraph (unLoc lunit)
326
327 msg <- mkBackpackMsg
328 (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph
329 when (failed ok) (liftIO $ exitWith (ExitFailure 1))
330
331 let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
332 export_mod ms = (ms_mod_name ms, ms_mod ms)
333 -- Export everything!
334 mods = [ export_mod ms | ms <- mgModSummaries mod_graph
335 , ms_hsc_src ms == HsSrcFile ]
336
337 -- Compile relevant only
338 hsc_env <- getSession
339 let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
340 linkables = map (expectJust "bkp link" . hm_linkable)
341 . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
342 $ home_mod_infos
343 getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us)
344 obj_files = concatMap getOfiles linkables
345 state = hsc_units hsc_env
346
347 let compat_fs = unitIdFS cid
348 compat_pn = PackageName compat_fs
349 unit_id = homeUnitId (hsc_home_unit hsc_env)
350
351 return GenericUnitInfo {
352 -- Stub data
353 unitAbiHash = "",
354 unitPackageId = PackageId compat_fs,
355 unitPackageName = compat_pn,
356 unitPackageVersion = makeVersion [],
357 unitId = unit_id,
358 unitComponentName = Nothing,
359 unitInstanceOf = cid,
360 unitInstantiations = insts,
361 -- Slight inefficiency here haha
362 unitExposedModules = map (\(m,n) -> (m,Just n)) mods,
363 unitHiddenModules = [], -- TODO: doc only
364 unitDepends = case session of
365 -- Technically, we should state that we depend
366 -- on all the indefinite libraries we used to
367 -- typecheck this. However, this field isn't
368 -- really used for anything, so we leave it
369 -- blank for now.
370 TcSession -> []
371 _ -> map (toUnitId . unwireUnit state)
372 $ deps ++ [ moduleUnit mod
373 | (_, mod) <- insts
374 , not (isHoleModule mod) ],
375 unitAbiDepends = [],
376 unitLinkerOptions = case session of
377 TcSession -> []
378 _ -> map ST.pack $ obj_files,
379 unitImportDirs = [ ST.pack $ hi_dir ],
380 unitIsExposed = False,
381 unitIsIndefinite = case session of
382 TcSession -> True
383 _ -> False,
384 -- nope
385 unitLibraries = [],
386 unitExtDepLibsSys = [],
387 unitExtDepLibsGhc = [],
388 unitLibraryDynDirs = [],
389 unitLibraryDirs = [],
390 unitExtDepFrameworks = [],
391 unitExtDepFrameworkDirs = [],
392 unitCcOptions = [],
393 unitIncludes = [],
394 unitIncludeDirs = [],
395 unitHaddockInterfaces = [],
396 unitHaddockHTMLs = [],
397 unitIsTrusted = False
398 }
399
400
401 addUnit conf
402 case mb_old_eps of
403 Just old_eps -> updateEpsGhc_ (const old_eps)
404 _ -> return ()
405
406 compileExe :: LHsUnit HsComponentId -> BkpM ()
407 compileExe lunit = do
408 msgUnitId mainUnit
409 let deps_w_rns = hsunitDeps False (unLoc lunit)
410 deps = map fst deps_w_rns
411 -- no renaming necessary
412 forM_ (zip [1..] deps) $ \(i, dep) ->
413 compileInclude (length deps) (i, dep)
414 withBkpExeSession deps_w_rns $ do
415 mod_graph <- hsunitModuleGraph (unLoc lunit)
416 msg <- mkBackpackMsg
417 (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph
418 when (failed ok) (liftIO $ exitWith (ExitFailure 1))
419
420 -- | Register a new virtual unit database containing a single unit
421 addUnit :: GhcMonad m => UnitInfo -> m ()
422 addUnit u = do
423 hsc_env <- getSession
424 logger <- getLogger
425 let dflags0 = hsc_dflags hsc_env
426 let old_unit_env = hsc_unit_env hsc_env
427 newdbs <- case ue_unit_dbs old_unit_env of
428 Nothing -> panic "addUnit: called too early"
429 Just dbs ->
430 let newdb = UnitDatabase
431 { unitDatabasePath = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
432 , unitDatabaseUnits = [u]
433 }
434 in return (dbs ++ [newdb]) -- added at the end because ordering matters
435 (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs)
436
437 -- update platform constants
438 dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
439
440 let unit_env = UnitEnv
441 { ue_platform = targetPlatform dflags
442 , ue_namever = ghcNameVersion dflags
443 , ue_home_unit = Just home_unit
444 , ue_hpt = ue_hpt old_unit_env
445 , ue_eps = ue_eps old_unit_env
446 , ue_units = unit_state
447 , ue_unit_dbs = Just dbs
448 }
449 setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
450
451 compileInclude :: Int -> (Int, Unit) -> BkpM ()
452 compileInclude n (i, uid) = do
453 hsc_env <- getSession
454 let pkgs = hsc_units hsc_env
455 msgInclude (i, n) uid
456 -- Check if we've compiled it already
457 case uid of
458 HoleUnit -> return ()
459 RealUnit _ -> return ()
460 VirtUnit i -> case lookupUnit pkgs uid of
461 Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i)
462 Just _ -> return ()
463
464 -- ----------------------------------------------------------------------------
465 -- Backpack monad
466
467 -- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
468 -- beyond the 'Session', c.f. 'BkpEnv'.
469 type BkpM = IOEnv BkpEnv
470
471 -- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv',
472 -- because we are going to update the 'HscEnv' as we go.
473 data BkpEnv
474 = BkpEnv {
475 -- | The session
476 bkp_session :: Session,
477 -- | The filename of the bkp file we're compiling
478 bkp_filename :: FilePath,
479 -- | Table of source units which we know how to compile
480 bkp_table :: Map UnitId (LHsUnit HsComponentId),
481 -- | When a package we are compiling includes another package
482 -- which has not been compiled, we bump the level and compile
483 -- that.
484 bkp_level :: Int
485 }
486
487 -- Blah, to get rid of the default instance for IOEnv
488 -- TODO: just make a proper new monad for BkpM, rather than use IOEnv
489 instance {-# OVERLAPPING #-} HasDynFlags BkpM where
490 getDynFlags = fmap hsc_dflags getSession
491 instance {-# OVERLAPPING #-} HasLogger BkpM where
492 getLogger = fmap hsc_logger getSession
493
494
495 instance GhcMonad BkpM where
496 getSession = do
497 Session s <- fmap bkp_session getEnv
498 readMutVar s
499 setSession hsc_env = do
500 Session s <- fmap bkp_session getEnv
501 writeMutVar s hsc_env
502
503 -- | Get the current 'BkpEnv'.
504 getBkpEnv :: BkpM BkpEnv
505 getBkpEnv = getEnv
506
507 -- | Get the nesting level, when recursively compiling modules.
508 getBkpLevel :: BkpM Int
509 getBkpLevel = bkp_level `fmap` getBkpEnv
510
511 -- | Run a 'BkpM' computation, with the nesting level bumped one.
512 innerBkpM :: BkpM a -> BkpM a
513 innerBkpM do_this =
514 -- NB: withTempSession mutates, so we don't have to worry
515 -- about bkp_session being stale.
516 updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this
517
518 -- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
519 updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
520 updateEpsGhc_ f = do
521 hsc_env <- getSession
522 liftIO $ atomicModifyIORef' (euc_eps (ue_eps (hsc_unit_env hsc_env))) (\x -> (f x, ()))
523
524 -- | Get the EPS from a 'GhcMonad'.
525 getEpsGhc :: GhcMonad m => m ExternalPackageState
526 getEpsGhc = do
527 hsc_env <- getSession
528 liftIO $ hscEPS hsc_env
529
530 -- | Run 'BkpM' in 'Ghc'.
531 initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
532 initBkpM file bkp m =
533 reifyGhc $ \session -> do
534 let env = BkpEnv {
535 bkp_session = session,
536 bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
537 bkp_filename = file,
538 bkp_level = 0
539 }
540 runIOEnv env m
541
542 -- ----------------------------------------------------------------------------
543 -- Messaging
544
545 -- | Print a compilation progress message, but with indentation according
546 -- to @level@ (for nested compilation).
547 backpackProgressMsg :: Int -> Logger -> SDoc -> IO ()
548 backpackProgressMsg level logger msg =
549 compilationProgressMsg logger $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr
550 <> msg
551
552 -- | Creates a 'Messager' for Backpack compilation; this is basically
553 -- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
554 -- handles indentation.
555 mkBackpackMsg :: BkpM Messager
556 mkBackpackMsg = do
557 level <- getBkpLevel
558 return $ \hsc_env mod_index recomp node ->
559 let dflags = hsc_dflags hsc_env
560 logger = hsc_logger hsc_env
561 state = hsc_units hsc_env
562 showMsg msg reason =
563 backpackProgressMsg level logger $ pprWithUnitState state $
564 showModuleIndex mod_index <>
565 msg <> showModMsg dflags (recompileRequired recomp) node
566 <> reason
567 in case node of
568 InstantiationNode _ ->
569 case recomp of
570 MustCompile -> showMsg (text "Instantiating ") empty
571 UpToDate
572 | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty
573 | otherwise -> return ()
574 RecompBecause reason -> showMsg (text "Instantiating ")
575 (text " [" <> pprWithUnitState state (ppr reason) <> text "]")
576 ModuleNode _ ->
577 case recomp of
578 MustCompile -> showMsg (text "Compiling ") empty
579 UpToDate
580 | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty
581 | otherwise -> return ()
582 RecompBecause reason -> showMsg (text "Compiling ")
583 (text " [" <> pprWithUnitState state (ppr reason) <> text "]")
584
585 -- | 'PprStyle' for Backpack messages; here we usually want the module to
586 -- be qualified (so we can tell how it was instantiated.) But we try not
587 -- to qualify packages so we can use simple names for them.
588 backpackStyle :: PprStyle
589 backpackStyle =
590 mkUserStyle
591 (QueryQualify neverQualifyNames
592 alwaysQualifyModules
593 neverQualifyPackages) AllTheWay
594
595 -- | Message when we initially process a Backpack unit.
596 msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
597 msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
598 logger <- getLogger
599 level <- getBkpLevel
600 liftIO . backpackProgressMsg level logger
601 $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn
602
603 -- | Message when we instantiate a Backpack unit.
604 msgUnitId :: Unit -> BkpM ()
605 msgUnitId pk = do
606 logger <- getLogger
607 hsc_env <- getSession
608 level <- getBkpLevel
609 let state = hsc_units hsc_env
610 liftIO . backpackProgressMsg level logger
611 $ pprWithUnitState state
612 $ text "Instantiating "
613 <> withPprStyle backpackStyle (ppr pk)
614
615 -- | Message when we include a Backpack unit.
616 msgInclude :: (Int,Int) -> Unit -> BkpM ()
617 msgInclude (i,n) uid = do
618 logger <- getLogger
619 hsc_env <- getSession
620 level <- getBkpLevel
621 let state = hsc_units hsc_env
622 liftIO . backpackProgressMsg level logger
623 $ pprWithUnitState state
624 $ showModuleIndex (i, n) <> text "Including "
625 <> withPprStyle backpackStyle (ppr uid)
626
627 -- ----------------------------------------------------------------------------
628 -- Conversion from PackageName to HsComponentId
629
630 type PackageNameMap a = UniqFM PackageName a
631
632 -- For now, something really simple, since we're not actually going
633 -- to use this for anything
634 unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
635 unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
636 = (pn, HsComponentId pn (UnitId fs))
637
638 bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
639 bkpPackageNameMap units = listToUFM (map unitDefines units)
640
641 renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
642 renameHsUnits pkgstate m units = map (fmap renameHsUnit) units
643 where
644
645 renamePackageName :: PackageName -> HsComponentId
646 renamePackageName pn =
647 case lookupUFM m pn of
648 Nothing ->
649 case lookupPackageName pkgstate pn of
650 Nothing -> error "no package name"
651 Just cid -> HsComponentId pn cid
652 Just hscid -> hscid
653
654 renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
655 renameHsUnit u =
656 HsUnit {
657 hsunitName = fmap renamePackageName (hsunitName u),
658 hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
659 }
660
661 renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
662 renameHsUnitDecl (DeclD a b c) = DeclD a b c
663 renameHsUnitDecl (IncludeD idecl) =
664 IncludeD IncludeDecl {
665 idUnitId = fmap renameHsUnitId (idUnitId idecl),
666 idModRenaming = idModRenaming idecl,
667 idSignatureInclude = idSignatureInclude idecl
668 }
669
670 renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
671 renameHsUnitId (HsUnitId ln subst)
672 = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)
673
674 renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
675 renameHsModuleSubst (lk, lm)
676 = (lk, fmap renameHsModuleId lm)
677
678 renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
679 renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
680 renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm
681
682 convertHsComponentId :: HsUnitId HsComponentId -> Unit
683 convertHsComponentId (HsUnitId (L _ hscid) subst)
684 = mkVirtUnit (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)
685
686 convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
687 convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)
688
689 convertHsModuleId :: HsModuleId HsComponentId -> Module
690 convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
691 convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsComponentId hsuid) modname
692
693
694
695 {-
696 ************************************************************************
697 * *
698 Module graph construction
699 * *
700 ************************************************************************
701 -}
702
703 -- | This is our version of GHC.Driver.Make.downsweep, but with a few modifications:
704 --
705 -- 1. Every module is required to be mentioned, so we don't do any funny
706 -- business with targets or recursively grabbing dependencies. (We
707 -- could support this in principle).
708 -- 2. We support inline modules, whose summary we have to synthesize ourself.
709 --
710 -- We don't bother trying to support GHC.Driver.Make for now, it's more trouble
711 -- than it's worth for inline modules.
712 hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph
713 hsunitModuleGraph unit = do
714 hsc_env <- getSession
715
716 let decls = hsunitBody unit
717 pn = hsPackageName (unLoc (hsunitName unit))
718 home_unit = hsc_home_unit hsc_env
719
720 -- 1. Create a HsSrcFile/HsigFile summary for every
721 -- explicitly mentioned module/signature.
722 let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) =
723 Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
724 get_decl _ = return Nothing
725 nodes <- catMaybes `fmap` mapM get_decl decls
726
727 -- 2. For each hole which does not already have an hsig file,
728 -- create an "empty" hsig file to induce compilation for the
729 -- requirement.
730 let hsig_set = Set.fromList
731 [ ms_mod_name ms
732 | ExtendedModSummary { emsModSummary = ms } <- nodes
733 , ms_hsc_src ms == HsigFile
734 ]
735 req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->
736 if Set.member mod_name hsig_set
737 then return Nothing
738 else fmap (Just . extendModSummaryNoDeps) $ summariseRequirement pn mod_name
739 -- Using extendModSummaryNoDeps here is okay because we're making a leaf node
740 -- representing a signature that can't depend on any other unit.
741
742 let graph_nodes = (ModuleNode <$> (nodes ++ req_nodes)) ++ (instantiationNodes (hsc_units hsc_env))
743 key_nodes = map mkNodeKey graph_nodes
744 -- This error message is not very good but .bkp mode is just for testing so
745 -- better to be direct rather than pretty.
746 when
747 (length key_nodes /= length (ordNub key_nodes))
748 (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes))
749
750 -- 3. Return the kaboodle
751 return $ mkModuleGraph' $ graph_nodes
752
753
754 summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
755 summariseRequirement pn mod_name = do
756 hsc_env <- getSession
757 let dflags = hsc_dflags hsc_env
758 let home_unit = hsc_home_unit hsc_env
759 let fopts = initFinderOpts dflags
760
761 let PackageName pn_fs = pn
762 let location = mkHomeModLocation2 fopts mod_name
763 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
764
765 env <- getBkpEnv
766 src_hash <- liftIO $ getFileHash (bkp_filename env)
767 hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
768 hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
769 let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
770
771 let fc = hsc_FC hsc_env
772 mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location
773
774 extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
775
776 return ModSummary {
777 ms_mod = mod,
778 ms_hsc_src = HsigFile,
779 ms_location = location,
780 ms_hs_hash = src_hash,
781 ms_obj_date = Nothing,
782 ms_dyn_obj_date = Nothing,
783 ms_iface_date = hi_timestamp,
784 ms_hie_date = hie_timestamp,
785 ms_srcimps = [],
786 ms_textual_imps = ((,) NoPkgQual . noLoc) <$> extra_sig_imports,
787 ms_ghc_prim_import = False,
788 ms_parsed_mod = Just (HsParsedModule {
789 hpm_module = L loc (HsModule {
790 hsmodAnn = noAnn,
791 hsmodLayout = NoLayoutInfo,
792 hsmodName = Just (L (noAnnSrcSpan loc) mod_name),
793 hsmodExports = Nothing,
794 hsmodImports = [],
795 hsmodDecls = [],
796 hsmodDeprecMessage = Nothing,
797 hsmodHaddockModHeader = Nothing
798 }),
799 hpm_src_files = []
800 }),
801 ms_hspp_file = "", -- none, it came inline
802 ms_hspp_opts = dflags,
803 ms_hspp_buf = Nothing
804 }
805
806 summariseDecl :: PackageName
807 -> HscSource
808 -> Located ModuleName
809 -> Maybe (Located HsModule)
810 -> BkpM ExtendedModSummary
811 summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
812 summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
813 = do hsc_env <- getSession
814 -- TODO: this looks for modules in the wrong place
815 r <- liftIO $ summariseModule hsc_env
816 emptyModNodeMap -- GHC API recomp not supported
817 (hscSourceToIsBoot hsc_src)
818 lmodname
819 Nothing -- GHC API buffer support not supported
820 [] -- No exclusions
821 case r of
822 Nothing -> throwOneError $ fmap GhcDriverMessage
823 $ mkPlainErrorMsgEnvelope loc (DriverBackpackModuleNotFound modname)
824 Just (Left err) -> throwErrors (fmap GhcDriverMessage err)
825 Just (Right summary) -> return summary
826
827 -- | Up until now, GHC has assumed a single compilation target per source file.
828 -- Backpack files with inline modules break this model, since a single file
829 -- may generate multiple output files. How do we decide to name these files?
830 -- Should there only be one output file? This function our current heuristic,
831 -- which is we make a "fake" module and use that.
832 hsModuleToModSummary :: PackageName
833 -> HscSource
834 -> ModuleName
835 -> Located HsModule
836 -> BkpM ExtendedModSummary
837 hsModuleToModSummary pn hsc_src modname
838 hsmod = do
839 let imps = hsmodImports (unLoc hsmod)
840 loc = getLoc hsmod
841 hsc_env <- getSession
842 -- Sort of the same deal as in GHC.Driver.Pipeline's getLocation
843 -- Use the PACKAGE NAME to find the location
844 let PackageName unit_fs = pn
845 dflags = hsc_dflags hsc_env
846 fopts = initFinderOpts dflags
847 -- Unfortunately, we have to define a "fake" location in
848 -- order to appease the various code which uses the file
849 -- name to figure out where to put, e.g. object files.
850 -- To add insult to injury, we don't even actually use
851 -- these filenames to figure out where the hi files go.
852 -- A travesty!
853 let location0 = mkHomeModLocation2 fopts modname
854 (unpackFS unit_fs </>
855 moduleNameSlashes modname)
856 (case hsc_src of
857 HsigFile -> "hsig"
858 HsBootFile -> "hs-boot"
859 HsSrcFile -> "hs")
860 -- DANGEROUS: bootifying can POISON the module finder cache
861 let location = case hsc_src of
862 HsBootFile -> addBootSuffixLocnOut location0
863 _ -> location0
864 -- This duplicates a pile of logic in GHC.Driver.Make
865 hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
866 hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
867
868 -- Also copied from 'getImports'
869 let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
870
871 -- GHC.Prim doesn't exist physically, so don't go looking for it.
872 (ordinary_imps, ghc_prim_import)
873 = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
874 ord_idecls
875
876 implicit_prelude = xopt LangExt.ImplicitPrelude dflags
877 implicit_imports = mkPrelImports modname loc
878 implicit_prelude imps
879
880 rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
881 convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
882
883 extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
884
885 let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
886 (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports
887
888 -- So that Finder can find it, even though it doesn't exist...
889 this_mod <- liftIO $ do
890 let home_unit = hsc_home_unit hsc_env
891 let fc = hsc_FC hsc_env
892 addHomeModuleToFinder fc home_unit modname location
893 return $ ExtendedModSummary
894 { emsModSummary =
895 ModSummary {
896 ms_mod = this_mod,
897 ms_hsc_src = hsc_src,
898 ms_location = location,
899 ms_hspp_file = (case hiDir dflags of
900 Nothing -> ""
901 Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",
902 ms_hspp_opts = dflags,
903 ms_hspp_buf = Nothing,
904 ms_srcimps = map convImport src_idecls,
905 ms_ghc_prim_import = not (null ghc_prim_import),
906 ms_textual_imps = normal_imports
907 -- We have to do something special here:
908 -- due to merging, requirements may end up with
909 -- extra imports
910 ++ ((,) NoPkgQual . noLoc <$> extra_sig_imports)
911 ++ ((,) NoPkgQual . noLoc <$> implicit_sigs),
912 -- This is our hack to get the parse tree to the right spot
913 ms_parsed_mod = Just (HsParsedModule {
914 hpm_module = hsmod,
915 hpm_src_files = [] -- TODO if we preprocessed it
916 }),
917 -- Source hash = fingerprint0, so the recompilation tests do not recompile
918 -- too much. In future, if necessary then could get the hash by just hashing the
919 -- relevant part of the .bkp file.
920 ms_hs_hash = fingerprint0,
921 ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
922 ms_dyn_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
923 ms_iface_date = hi_timestamp,
924 ms_hie_date = hie_timestamp
925 }
926 , emsInstantiatedUnits = inst_deps
927 }
928
929 -- | Create a new, externally provided hashed unit id from
930 -- a hash.
931 newUnitId :: UnitId -> Maybe FastString -> UnitId
932 newUnitId uid mhash = case mhash of
933 Nothing -> uid
934 Just hash -> UnitId (unitIdFS uid `appendFS` mkFastString "+" `appendFS` hash)