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