Make module membership on ModuleGraph faster
[ghc.git] / compiler / backpack / DriverBkp.hs
1 {-# LANGUAGE NondecreasingIndentation #-}
2 {-# LANGUAGE TypeSynonymInstances #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE CPP #-}
5
6 -- | This is the driver for the 'ghc --backpack' mode, which
7 -- is a reimplementation of the "package manager" bits of
8 -- Backpack directly in GHC. The basic method of operation
9 -- is to compile packages and then directly insert them into
10 -- GHC's in memory database.
11 --
12 -- The compilation products of this mode aren't really suitable
13 -- for Cabal, because GHC makes up component IDs for the things
14 -- it builds and doesn't serialize out the database contents.
15 -- But it's still handy for constructing tests.
16
17 module DriverBkp (doBackpack) where
18
19 #include "HsVersions.h"
20
21 -- In a separate module because it hooks into the parser.
22 import BkpSyn
23
24 import GHC hiding (Failed, Succeeded)
25 import Packages
26 import Parser
27 import Lexer
28 import GhcMonad
29 import DynFlags
30 import TcRnMonad
31 import TcRnDriver
32 import Module
33 import HscTypes
34 import StringBuffer
35 import FastString
36 import ErrUtils
37 import SrcLoc
38 import HscMain
39 import UniqFM
40 import UniqDFM
41 import Outputable
42 import Maybes
43 import HeaderInfo
44 import MkIface
45 import GhcMake
46 import UniqDSet
47 import PrelNames
48 import BasicTypes hiding (SuccessFlag(..))
49 import Finder
50 import Util
51
52 import qualified GHC.LanguageExtensions as LangExt
53
54 import Panic
55 import Data.List
56 import System.Exit
57 import Control.Monad
58 import System.FilePath
59 import Data.Version
60
61 -- for the unification
62 import Data.IORef
63 import Data.Map (Map)
64 import qualified Data.Map as Map
65
66 -- | Entry point to compile a Backpack file.
67 doBackpack :: [FilePath] -> Ghc ()
68 doBackpack [src_filename] = do
69 -- Apply options from file to dflags
70 dflags0 <- getDynFlags
71 let dflags1 = dflags0
72 src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename
73 (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
74 modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})
75 -- Cribbed from: preprocessFile / DriverPipeline
76 liftIO $ checkProcessArgsResult dflags unhandled_flags
77 liftIO $ handleFlagWarnings dflags warns
78 -- TODO: Preprocessing not implemented
79
80 buf <- liftIO $ hGetStringBuffer src_filename
81 let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
82 case unP parseBackpack (mkPState dflags buf loc) of
83 PFailed _ span err -> do
84 liftIO $ throwOneError (mkPlainErrMsg dflags span err)
85 POk _ pkgname_bkp -> do
86 -- OK, so we have an LHsUnit PackageName, but we want an
87 -- LHsUnit HsComponentId. So let's rename it.
88 let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp
89 initBkpM src_filename bkp $
90 forM_ (zip [1..] bkp) $ \(i, lunit) -> do
91 let comp_name = unLoc (hsunitName (unLoc lunit))
92 msgTopPackage (i,length bkp) comp_name
93 innerBkpM $ do
94 let (cid, insts) = computeUnitId lunit
95 if null insts
96 then if cid == ComponentId (fsLit "main")
97 then compileExe lunit
98 else compileUnit cid []
99 else typecheckUnit cid insts
100 doBackpack _ =
101 throwGhcException (CmdLineError "--backpack can only process a single file")
102
103 computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)])
104 computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
105 where
106 cid = hsComponentId (unLoc (hsunitName unit))
107 reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
108 get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname
109 get_reqs (DeclD ModuleD _ _) = emptyUniqDSet
110 get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =
111 unitIdFreeHoles (convertHsUnitId hsuid)
112
113 -- | Tiny enum for all types of Backpack operations we may do.
114 data SessionType
115 -- | A compilation operation which will result in a
116 -- runnable executable being produced.
117 = ExeSession
118 -- | A type-checking operation which produces only
119 -- interface files, no object files.
120 | TcSession
121 -- | A compilation operation which produces both
122 -- interface files and object files.
123 | CompSession
124 deriving (Eq)
125
126 -- | Create a temporary Session to do some sort of type checking or
127 -- compilation.
128 withBkpSession :: ComponentId
129 -> [(ModuleName, Module)]
130 -> [(UnitId, ModRenaming)]
131 -> SessionType -- what kind of session are we doing
132 -> BkpM a -- actual action to run
133 -> BkpM a
134 withBkpSession cid insts deps session_type do_this = do
135 dflags <- getDynFlags
136 let (ComponentId cid_fs) = cid
137 is_primary = False
138 uid_str = unpackFS (hashUnitId cid insts)
139 cid_str = unpackFS cid_fs
140 -- There are multiple units in a single Backpack file, so we
141 -- need to separate out the results in those cases. Right now,
142 -- we follow this hierarchy:
143 -- $outputdir/$compid --> typecheck results
144 -- $outputdir/$compid/$unitid --> compile results
145 key_base p | Just f <- p dflags = f
146 | otherwise = "."
147 sub_comp p | is_primary = p
148 | otherwise = p </> cid_str
149 outdir p | CompSession <- session_type
150 -- Special case when package is definite
151 , not (null insts) = sub_comp (key_base p) </> uid_str
152 | otherwise = sub_comp (key_base p)
153 withTempSession (overHscDynFlags (\dflags ->
154 -- If we're type-checking an indefinite package, we want to
155 -- turn on interface writing. However, if the user also
156 -- explicitly passed in `-fno-code`, we DON'T want to write
157 -- interfaces unless the user also asked for `-fwrite-interface`.
158 -- See Note [-fno-code mode]
159 (case session_type of
160 -- Make sure to write interfaces when we are type-checking
161 -- indefinite packages.
162 TcSession | hscTarget dflags /= HscNothing
163 -> flip gopt_set Opt_WriteInterface
164 | otherwise -> id
165 CompSession -> id
166 ExeSession -> id) $
167 dflags {
168 hscTarget = case session_type of
169 TcSession -> HscNothing
170 _ -> hscTarget dflags,
171 thisUnitIdInsts_ = Just insts,
172 thisComponentId_ = Just cid,
173 thisInstalledUnitId =
174 case session_type of
175 TcSession -> newInstalledUnitId cid Nothing
176 -- No hash passed if no instances
177 _ | null insts -> newInstalledUnitId cid Nothing
178 | otherwise -> newInstalledUnitId cid (Just (hashUnitId cid insts)),
179 -- Setup all of the output directories according to our hierarchy
180 objectDir = Just (outdir objectDir),
181 hiDir = Just (outdir hiDir),
182 stubDir = Just (outdir stubDir),
183 -- Unset output-file for non exe builds
184 outputFile = if session_type == ExeSession
185 then outputFile dflags
186 else Nothing,
187 -- Clear the import path so we don't accidentally grab anything
188 importPaths = [],
189 -- Synthesized the flags
190 packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
191 let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
192 in ExposePackage
193 (showSDoc dflags
194 (text "-unit-id" <+> ppr uid <+> ppr rn))
195 (UnitIdArg uid) rn) deps
196 } )) $ do
197 dflags <- getSessionDynFlags
198 -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
199 -- Calls initPackages
200 _ <- setSessionDynFlags dflags
201 do_this
202
203 withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
204 withBkpExeSession deps do_this = do
205 withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this
206
207 getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
208 getSource cid = do
209 bkp_env <- getBkpEnv
210 case Map.lookup cid (bkp_table bkp_env) of
211 Nothing -> pprPanic "missing needed dependency" (ppr cid)
212 Just lunit -> return lunit
213
214 typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
215 typecheckUnit cid insts = do
216 lunit <- getSource cid
217 buildUnit TcSession cid insts lunit
218
219 compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
220 compileUnit cid insts = do
221 -- Let everyone know we're building this unit ID
222 msgUnitId (newUnitId cid insts)
223 lunit <- getSource cid
224 buildUnit CompSession cid insts lunit
225
226 -- | Compute the dependencies with instantiations of a syntactic
227 -- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a
228 -- unit file, return the 'UnitId' corresponding to @p[A=<A>]@.
229 -- The @include_sigs@ parameter controls whether or not we also
230 -- include @dependency signature@ declarations in this calculation.
231 --
232 -- Invariant: this NEVER returns InstalledUnitId.
233 hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]
234 hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)
235 where
236 get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))
237 | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)]
238 | otherwise = []
239 where
240 go Nothing = ModRenaming True []
241 go (Just lrns) = ModRenaming False (map convRn lrns)
242 where
243 convRn (L _ (Renaming (L _ from) Nothing)) = (from, from)
244 convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)
245 get_dep _ = []
246
247 buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
248 buildUnit session cid insts lunit = do
249 -- NB: include signature dependencies ONLY when typechecking.
250 -- If we're compiling, it's not necessary to recursively
251 -- compile a signature since it isn't going to produce
252 -- any object files.
253 let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)
254 raw_deps = map fst deps_w_rns
255 dflags <- getDynFlags
256 -- The compilation dependencies are just the appropriately filled
257 -- in unit IDs which must be compiled before we can compile.
258 let hsubst = listToUFM insts
259 deps0 = map (renameHoleUnitId dflags hsubst) raw_deps
260
261 -- Build dependencies OR make sure they make sense. BUT NOTE,
262 -- we can only check the ones that are fully filled; the rest
263 -- we have to defer until we've typechecked our local signature.
264 -- TODO: work this into GhcMake!!
265 forM_ (zip [1..] deps0) $ \(i, dep) ->
266 case session of
267 TcSession -> return ()
268 _ -> compileInclude (length deps0) (i, dep)
269
270 dflags <- getDynFlags
271 -- IMPROVE IT
272 let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0
273
274 mb_old_eps <- case session of
275 TcSession -> fmap Just getEpsGhc
276 _ -> return Nothing
277
278 conf <- withBkpSession cid insts deps_w_rns session $ do
279
280 dflags <- getDynFlags
281 mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
282 -- pprTrace "mod_graph" (ppr mod_graph) $ return ()
283
284 msg <- mkBackpackMsg
285 ok <- load' LoadAllTargets (Just msg) mod_graph
286 when (failed ok) (liftIO $ exitWith (ExitFailure 1))
287
288 let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
289 export_mod ms = (ms_mod_name ms, ms_mod ms)
290 -- Export everything!
291 mods = [ export_mod ms | ms <- mgModSummaries mod_graph
292 , ms_hsc_src ms == HsSrcFile ]
293
294 -- Compile relevant only
295 hsc_env <- getSession
296 let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
297 linkables = map (expectJust "bkp link" . hm_linkable)
298 . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
299 $ home_mod_infos
300 getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
301 obj_files = concatMap getOfiles linkables
302
303 let compat_fs = (case cid of ComponentId fs -> fs)
304 compat_pn = PackageName compat_fs
305
306 return InstalledPackageInfo {
307 -- Stub data
308 abiHash = "",
309 sourcePackageId = SourcePackageId compat_fs,
310 packageName = compat_pn,
311 packageVersion = makeVersion [0],
312 unitId = toInstalledUnitId (thisPackage dflags),
313 sourceLibName = Nothing,
314 componentId = cid,
315 instantiatedWith = insts,
316 -- Slight inefficiency here haha
317 exposedModules = map (\(m,n) -> (m,Just n)) mods,
318 hiddenModules = [], -- TODO: doc only
319 depends = case session of
320 -- Technically, we should state that we depend
321 -- on all the indefinite libraries we used to
322 -- typecheck this. However, this field isn't
323 -- really used for anything, so we leave it
324 -- blank for now.
325 TcSession -> []
326 _ -> map (toInstalledUnitId . unwireUnitId dflags)
327 $ deps ++ [ moduleUnitId mod
328 | (_, mod) <- insts
329 , not (isHoleModule mod) ],
330 abiDepends = [],
331 ldOptions = case session of
332 TcSession -> []
333 _ -> obj_files,
334 importDirs = [ hi_dir ],
335 exposed = False,
336 indefinite = case session of
337 TcSession -> True
338 _ -> False,
339 -- nope
340 hsLibraries = [],
341 extraLibraries = [],
342 extraGHCiLibraries = [],
343 libraryDynDirs = [],
344 libraryDirs = [],
345 frameworks = [],
346 frameworkDirs = [],
347 ccOptions = [],
348 includes = [],
349 includeDirs = [],
350 haddockInterfaces = [],
351 haddockHTMLs = [],
352 trusted = False
353 }
354
355
356 addPackage conf
357 case mb_old_eps of
358 Just old_eps -> updateEpsGhc_ (const old_eps)
359 _ -> return ()
360
361 compileExe :: LHsUnit HsComponentId -> BkpM ()
362 compileExe lunit = do
363 msgUnitId mainUnitId
364 let deps_w_rns = hsunitDeps False (unLoc lunit)
365 deps = map fst deps_w_rns
366 -- no renaming necessary
367 forM_ (zip [1..] deps) $ \(i, dep) ->
368 compileInclude (length deps) (i, dep)
369 withBkpExeSession deps_w_rns $ do
370 dflags <- getDynFlags
371 mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
372 msg <- mkBackpackMsg
373 ok <- load' LoadAllTargets (Just msg) mod_graph
374 when (failed ok) (liftIO $ exitWith (ExitFailure 1))
375
376 addPackage :: GhcMonad m => PackageConfig -> m ()
377 addPackage pkg = do
378 dflags0 <- GHC.getSessionDynFlags
379 case pkgDatabase dflags0 of
380 Nothing -> panic "addPackage: called too early"
381 Just pkgs -> do let dflags = dflags0 { pkgDatabase =
382 Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }
383 _ <- GHC.setSessionDynFlags dflags
384 -- By this time, the global ref has probably already
385 -- been forced, in which case doing this isn't actually
386 -- going to do you any good.
387 -- dflags <- GHC.getSessionDynFlags
388 -- liftIO $ setUnsafeGlobalDynFlags dflags
389 return ()
390
391 -- Precondition: UnitId is NOT InstalledUnitId
392 compileInclude :: Int -> (Int, UnitId) -> BkpM ()
393 compileInclude n (i, uid) = do
394 hsc_env <- getSession
395 let dflags = hsc_dflags hsc_env
396 msgInclude (i, n) uid
397 -- Check if we've compiled it already
398 case lookupPackage dflags uid of
399 Nothing -> do
400 case splitUnitIdInsts uid of
401 (_, Just indef) ->
402 innerBkpM $ compileUnit (indefUnitIdComponentId indef)
403 (indefUnitIdInsts indef)
404 _ -> return ()
405 Just _ -> return ()
406
407 -- ----------------------------------------------------------------------------
408 -- Backpack monad
409
410 -- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
411 -- beyond the 'Session', c.f. 'BkpEnv'.
412 type BkpM = IOEnv BkpEnv
413
414 -- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv',
415 -- because we are going to update the 'HscEnv' as we go.
416 data BkpEnv
417 = BkpEnv {
418 -- | The session
419 bkp_session :: Session,
420 -- | The filename of the bkp file we're compiling
421 bkp_filename :: FilePath,
422 -- | Table of source units which we know how to compile
423 bkp_table :: Map ComponentId (LHsUnit HsComponentId),
424 -- | When a package we are compiling includes another package
425 -- which has not been compiled, we bump the level and compile
426 -- that.
427 bkp_level :: Int
428 }
429
430 -- Blah, to get rid of the default instance for IOEnv
431 -- TODO: just make a proper new monad for BkpM, rather than use IOEnv
432 instance {-# OVERLAPPING #-} HasDynFlags BkpM where
433 getDynFlags = fmap hsc_dflags getSession
434
435 instance GhcMonad BkpM where
436 getSession = do
437 Session s <- fmap bkp_session getEnv
438 readMutVar s
439 setSession hsc_env = do
440 Session s <- fmap bkp_session getEnv
441 writeMutVar s hsc_env
442
443 -- | Get the current 'BkpEnv'.
444 getBkpEnv :: BkpM BkpEnv
445 getBkpEnv = getEnv
446
447 -- | Get the nesting level, when recursively compiling modules.
448 getBkpLevel :: BkpM Int
449 getBkpLevel = bkp_level `fmap` getBkpEnv
450
451 -- | Apply a function on 'DynFlags' on an 'HscEnv'
452 overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
453 overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }
454
455 -- | Run a 'BkpM' computation, with the nesting level bumped one.
456 innerBkpM :: BkpM a -> BkpM a
457 innerBkpM do_this = do
458 -- NB: withTempSession mutates, so we don't have to worry
459 -- about bkp_session being stale.
460 updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this
461
462 -- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
463 updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
464 updateEpsGhc_ f = do
465 hsc_env <- getSession
466 liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))
467
468 -- | Get the EPS from a 'GhcMonad'.
469 getEpsGhc :: GhcMonad m => m ExternalPackageState
470 getEpsGhc = do
471 hsc_env <- getSession
472 liftIO $ readIORef (hsc_EPS hsc_env)
473
474 -- | Run 'BkpM' in 'Ghc'.
475 initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
476 initBkpM file bkp m = do
477 reifyGhc $ \session -> do
478 let env = BkpEnv {
479 bkp_session = session,
480 bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
481 bkp_filename = file,
482 bkp_level = 0
483 }
484 runIOEnv env m
485
486 -- ----------------------------------------------------------------------------
487 -- Messaging
488
489 -- | Print a compilation progress message, but with indentation according
490 -- to @level@ (for nested compilation).
491 backpackProgressMsg :: Int -> DynFlags -> String -> IO ()
492 backpackProgressMsg level dflags msg =
493 compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg
494
495 -- | Creates a 'Messager' for Backpack compilation; this is basically
496 -- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
497 -- handles indentation.
498 mkBackpackMsg :: BkpM Messager
499 mkBackpackMsg = do
500 level <- getBkpLevel
501 return $ \hsc_env mod_index recomp mod_summary ->
502 let dflags = hsc_dflags hsc_env
503 showMsg msg reason =
504 backpackProgressMsg level dflags $
505 showModuleIndex mod_index ++
506 msg ++ showModMsg dflags (hscTarget dflags)
507 (recompileRequired recomp) mod_summary
508 ++ reason
509 in case recomp of
510 MustCompile -> showMsg "Compiling " ""
511 UpToDate
512 | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
513 | otherwise -> return ()
514 RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
515
516 -- | 'PprStyle' for Backpack messages; here we usually want the module to
517 -- be qualified (so we can tell how it was instantiated.) But we try not
518 -- to qualify packages so we can use simple names for them.
519 backpackStyle :: DynFlags -> PprStyle
520 backpackStyle dflags =
521 mkUserStyle dflags
522 (QueryQualify neverQualifyNames
523 alwaysQualifyModules
524 neverQualifyPackages) AllTheWay
525
526 -- | Message when we initially process a Backpack unit.
527 msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
528 msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
529 dflags <- getDynFlags
530 level <- getBkpLevel
531 liftIO . backpackProgressMsg level dflags
532 $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn
533
534 -- | Message when we instantiate a Backpack unit.
535 msgUnitId :: UnitId -> BkpM ()
536 msgUnitId pk = do
537 dflags <- getDynFlags
538 level <- getBkpLevel
539 liftIO . backpackProgressMsg level dflags
540 $ "Instantiating " ++ renderWithStyle dflags (ppr pk)
541 (backpackStyle dflags)
542
543 -- | Message when we include a Backpack unit.
544 msgInclude :: (Int,Int) -> UnitId -> BkpM ()
545 msgInclude (i,n) uid = do
546 dflags <- getDynFlags
547 level <- getBkpLevel
548 liftIO . backpackProgressMsg level dflags
549 $ showModuleIndex (i, n) ++ "Including " ++
550 renderWithStyle dflags (ppr uid) (backpackStyle dflags)
551
552 -- ----------------------------------------------------------------------------
553 -- Conversion from PackageName to HsComponentId
554
555 type PackageNameMap a = Map PackageName a
556
557 -- For now, something really simple, since we're not actually going
558 -- to use this for anything
559 unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
560 unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
561 = (pn, HsComponentId pn (ComponentId fs))
562
563 packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
564 packageNameMap units = Map.fromList (map unitDefines units)
565
566 renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
567 renameHsUnits dflags m units = map (fmap renameHsUnit) units
568 where
569
570 renamePackageName :: PackageName -> HsComponentId
571 renamePackageName pn =
572 case Map.lookup pn m of
573 Nothing ->
574 case lookupPackageName dflags pn of
575 Nothing -> error "no package name"
576 Just cid -> HsComponentId pn cid
577 Just hscid -> hscid
578
579 renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
580 renameHsUnit u =
581 HsUnit {
582 hsunitName = fmap renamePackageName (hsunitName u),
583 hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
584 }
585
586 renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
587 renameHsUnitDecl (DeclD a b c) = DeclD a b c
588 renameHsUnitDecl (IncludeD idecl) =
589 IncludeD IncludeDecl {
590 idUnitId = fmap renameHsUnitId (idUnitId idecl),
591 idModRenaming = idModRenaming idecl,
592 idSignatureInclude = idSignatureInclude idecl
593 }
594
595 renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
596 renameHsUnitId (HsUnitId ln subst)
597 = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)
598
599 renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
600 renameHsModuleSubst (lk, lm)
601 = (lk, fmap renameHsModuleId lm)
602
603 renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
604 renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
605 renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm
606
607 convertHsUnitId :: HsUnitId HsComponentId -> UnitId
608 convertHsUnitId (HsUnitId (L _ hscid) subst)
609 = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)
610
611 convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
612 convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)
613
614 convertHsModuleId :: HsModuleId HsComponentId -> Module
615 convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
616 convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname
617
618
619
620 {-
621 ************************************************************************
622 * *
623 Module graph construction
624 * *
625 ************************************************************************
626 -}
627
628 -- | This is our version of GhcMake.downsweep, but with a few modifications:
629 --
630 -- 1. Every module is required to be mentioned, so we don't do any funny
631 -- business with targets or recursively grabbing dependencies. (We
632 -- could support this in principle).
633 -- 2. We support inline modules, whose summary we have to synthesize ourself.
634 --
635 -- We don't bother trying to support GhcMake for now, it's more trouble
636 -- than it's worth for inline modules.
637 hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
638 hsunitModuleGraph dflags unit = do
639 let decls = hsunitBody unit
640 pn = hsPackageName (unLoc (hsunitName unit))
641
642 -- 1. Create a HsSrcFile/HsigFile summary for every
643 -- explicitly mentioned module/signature.
644 let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do
645 let hsc_src = case dt of
646 ModuleD -> HsSrcFile
647 SignatureD -> HsigFile
648 Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
649 get_decl _ = return Nothing
650 nodes <- catMaybes `fmap` mapM get_decl decls
651
652 -- 2. For each hole which does not already have an hsig file,
653 -- create an "empty" hsig file to induce compilation for the
654 -- requirement.
655 let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)
656 | n <- nodes ]
657 req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->
658 let has_local = Map.member (mod_name, True) node_map
659 in if has_local
660 then return Nothing
661 else fmap Just $ summariseRequirement pn mod_name
662
663 -- 3. Return the kaboodle
664 return $ mkModuleGraph $ nodes ++ req_nodes
665
666 summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
667 summariseRequirement pn mod_name = do
668 hsc_env <- getSession
669 let dflags = hsc_dflags hsc_env
670
671 let PackageName pn_fs = pn
672 location <- liftIO $ mkHomeModLocation2 dflags mod_name
673 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
674
675 env <- getBkpEnv
676 time <- liftIO $ getModificationUTCTime (bkp_filename env)
677 hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
678 let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
679
680 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
681
682 extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
683
684 return ModSummary {
685 ms_mod = mod,
686 ms_hsc_src = HsigFile,
687 ms_location = location,
688 ms_hs_date = time,
689 ms_obj_date = Nothing,
690 ms_iface_date = hi_timestamp,
691 ms_srcimps = [],
692 ms_textual_imps = extra_sig_imports,
693 ms_parsed_mod = Just (HsParsedModule {
694 hpm_module = L loc (HsModule {
695 hsmodName = Just (L loc mod_name),
696 hsmodExports = Nothing,
697 hsmodImports = [],
698 hsmodDecls = [],
699 hsmodDeprecMessage = Nothing,
700 hsmodHaddockModHeader = Nothing
701 }),
702 hpm_src_files = [],
703 hpm_annotations = (Map.empty, Map.empty)
704 }),
705 ms_hspp_file = "", -- none, it came inline
706 ms_hspp_opts = dflags,
707 ms_hspp_buf = Nothing
708 }
709
710 summariseDecl :: PackageName
711 -> HscSource
712 -> Located ModuleName
713 -> Maybe (Located (HsModule GhcPs))
714 -> BkpM ModSummary
715 summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
716 summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
717 = do hsc_env <- getSession
718 let dflags = hsc_dflags hsc_env
719 -- TODO: this looks for modules in the wrong place
720 r <- liftIO $ summariseModule hsc_env
721 Map.empty -- GHC API recomp not supported
722 (hscSourceToIsBoot hsc_src)
723 lmodname
724 True -- Target lets you disallow, but not here
725 Nothing -- GHC API buffer support not supported
726 [] -- No exclusions
727 case r of
728 Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))
729 Just (Left err) -> throwOneError err
730 Just (Right summary) -> return summary
731
732 -- | Up until now, GHC has assumed a single compilation target per source file.
733 -- Backpack files with inline modules break this model, since a single file
734 -- may generate multiple output files. How do we decide to name these files?
735 -- Should there only be one output file? This function our current heuristic,
736 -- which is we make a "fake" module and use that.
737 hsModuleToModSummary :: PackageName
738 -> HscSource
739 -> ModuleName
740 -> Located (HsModule GhcPs)
741 -> BkpM ModSummary
742 hsModuleToModSummary pn hsc_src modname
743 hsmod = do
744 let imps = hsmodImports (unLoc hsmod)
745 loc = getLoc hsmod
746 hsc_env <- getSession
747 -- Sort of the same deal as in DriverPipeline's getLocation
748 -- Use the PACKAGE NAME to find the location
749 let PackageName unit_fs = pn
750 dflags = hsc_dflags hsc_env
751 -- Unfortunately, we have to define a "fake" location in
752 -- order to appease the various code which uses the file
753 -- name to figure out where to put, e.g. object files.
754 -- To add insult to injury, we don't even actually use
755 -- these filenames to figure out where the hi files go.
756 -- A travesty!
757 location0 <- liftIO $ mkHomeModLocation2 dflags modname
758 (unpackFS unit_fs </>
759 moduleNameSlashes modname)
760 (case hsc_src of
761 HsigFile -> "hsig"
762 HsBootFile -> "hs-boot"
763 HsSrcFile -> "hs")
764 -- DANGEROUS: bootifying can POISON the module finder cache
765 let location = case hsc_src of
766 HsBootFile -> addBootSuffixLocn location0
767 _ -> location0
768 -- This duplicates a pile of logic in GhcMake
769 env <- getBkpEnv
770 time <- liftIO $ getModificationUTCTime (bkp_filename env)
771 hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
772
773 -- Also copied from 'getImports'
774 let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
775
776 -- GHC.Prim doesn't exist physically, so don't go looking for it.
777 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
778 ord_idecls
779
780 implicit_prelude = xopt LangExt.ImplicitPrelude dflags
781 implicit_imports = mkPrelImports modname loc
782 implicit_prelude imps
783 convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
784
785 extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
786
787 let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
788 required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports
789
790 -- So that Finder can find it, even though it doesn't exist...
791 this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location
792 return ModSummary {
793 ms_mod = this_mod,
794 ms_hsc_src = hsc_src,
795 ms_location = location,
796 ms_hspp_file = (case hiDir dflags of
797 Nothing -> ""
798 Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",
799 ms_hspp_opts = dflags,
800 ms_hspp_buf = Nothing,
801 ms_srcimps = map convImport src_idecls,
802 ms_textual_imps = normal_imports
803 -- We have to do something special here:
804 -- due to merging, requirements may end up with
805 -- extra imports
806 ++ extra_sig_imports
807 ++ required_by_imports,
808 -- This is our hack to get the parse tree to the right spot
809 ms_parsed_mod = Just (HsParsedModule {
810 hpm_module = hsmod,
811 hpm_src_files = [], -- TODO if we preprocessed it
812 hpm_annotations = (Map.empty, Map.empty) -- BOGUS
813 }),
814 ms_hs_date = time,
815 ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
816 ms_iface_date = hi_timestamp
817 }
818
819 -- | Create a new, externally provided hashed unit id from
820 -- a hash.
821 newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
822 newInstalledUnitId (ComponentId cid_fs) (Just fs)
823 = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
824 newInstalledUnitId (ComponentId cid_fs) Nothing
825 = InstalledUnitId cid_fs