mirrored from https://gitlab.haskell.org/ghc/ghc.git
/
MkIface.hs
2051 lines (1788 loc) · 86 KB
/
MkIface.hs
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
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-
(c) The University of Glasgow 2006-2008
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-}
{-# LANGUAGE CPP, NondecreasingIndentation #-}
-- | Module for constructing @ModIface@ values (interface files),
-- writing them to disk and comparing two versions to see if
-- recompilation is required.
module MkIface (
mkUsedNames,
mkDependencies,
mkIface, -- Build a ModIface from a ModGuts,
-- including computing version information
mkIfaceTc,
writeIfaceFile, -- Write the interface file
checkOldIface, -- See if recompilation is required, by
-- comparing version information
RecompileRequired(..), recompileRequired,
tyThingToIfaceDecl -- Converting things to their Iface equivalents
) where
{-
-----------------------------------------------
Recompilation checking
-----------------------------------------------
A complete description of how recompilation checking works can be
found in the wiki commentary:
http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
Please read the above page for a top-down description of how this all
works. Notes below cover specific issues related to the implementation.
Basic idea:
* In the mi_usages information in an interface, we record the
fingerprint of each free variable of the module
* In mkIface, we compute the fingerprint of each exported thing A.f.
For each external thing that A.f refers to, we include the fingerprint
of the external reference when computing the fingerprint of A.f. So
if anything that A.f depends on changes, then A.f's fingerprint will
change.
Also record any dependent files added with
* addDependentFile
* #include
* -optP-include
* In checkOldIface we compare the mi_usages for the module with
the actual fingerprint for all each thing recorded in mi_usages
-}
#include "HsVersions.h"
import IfaceSyn
import LoadIface
import FlagChecker
import Id
import IdInfo
import Demand
import Coercion( tidyCo )
import Annotations
import CoreSyn
import CoreFVs
import Class
import Kind
import TyCon
import CoAxiom
import ConLike
import DataCon
import PatSyn
import Type
import TcType
import TysPrim ( alphaTyVars )
import InstEnv
import FamInstEnv
import TcRnMonad
import HsSyn
import HscTypes
import Finder
import DynFlags
import VarEnv
import VarSet
import Var
import Name
import Avail
import RdrName
import NameEnv
import NameSet
import Module
import BinIface
import ErrUtils
import Digraph
import SrcLoc
import Outputable
import BasicTypes hiding ( SuccessFlag(..) )
import UniqFM
import Unique
import Util hiding ( eqListBy )
import FastString
import Maybes
import ListSetOps
import Binary
import Fingerprint
import Bag
import Exception
import Control.Monad
import Data.Function
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Ord
import Data.IORef
import System.Directory
import System.FilePath
{-
************************************************************************
* *
\subsection{Completing an interface}
* *
************************************************************************
-}
mkIface :: HscEnv
-> Maybe Fingerprint -- The old fingerprint, if we have it
-> ModDetails -- The trimmed, tidied interface
-> ModGuts -- Usages, deprecations, etc
-> IO (Messages,
Maybe (ModIface, -- The new one
Bool)) -- True <=> there was an old Iface, and the
-- new one is identical, so no need
-- to write it
mkIface hsc_env maybe_old_fingerprint mod_details
ModGuts{ mg_module = this_mod,
mg_boot = is_boot,
mg_used_names = used_names,
mg_used_th = used_th,
mg_deps = deps,
mg_dir_imps = dir_imp_mods,
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_warns = warns,
mg_hpc_info = hpc_info,
mg_safe_haskell = safe_mode,
mg_trust_pkg = self_trust,
mg_dependent_files = dependent_files
}
= mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names used_th deps rdr_env fix_env
warns hpc_info dir_imp_mods self_trust dependent_files
safe_mode mod_details
-- | make an interface from the results of typechecking only. Useful
-- for non-optimising compilation, or where we aren't generating any
-- object code at all ('HscNothing').
mkIfaceTc :: HscEnv
-> Maybe Fingerprint -- The old fingerprint, if we have it
-> SafeHaskellMode -- The safe haskell mode
-> ModDetails -- gotten from mkBootModDetails, probably
-> TcGblEnv -- Usages, deprecations, etc
-> IO (Messages, Maybe (ModIface, Bool))
mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
tc_result@TcGblEnv{ tcg_mod = this_mod,
tcg_src = hsc_src,
tcg_imports = imports,
tcg_rdr_env = rdr_env,
tcg_fix_env = fix_env,
tcg_warns = warns,
tcg_hpc = other_hpc_info,
tcg_th_splice_used = tc_splice_used,
tcg_dependent_files = dependent_files
}
= do
let used_names = mkUsedNames tc_result
deps <- mkDependencies tc_result
let hpc_info = emptyHpcInfo other_hpc_info
used_th <- readIORef tc_splice_used
dep_files <- (readIORef dependent_files)
mkIface_ hsc_env maybe_old_fingerprint
this_mod (hsc_src == HsBootFile) used_names
used_th deps rdr_env
fix_env warns hpc_info (imp_mods imports)
(imp_trust_own_pkg imports) dep_files safe_mode mod_details
mkUsedNames :: TcGblEnv -> NameSet
mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
-- | Extract information from the rename and typecheck phases to produce
-- a dependencies information for the module being compiled.
mkDependencies :: TcGblEnv -> IO Dependencies
mkDependencies
TcGblEnv{ tcg_mod = mod,
tcg_imports = imports,
tcg_th_used = th_var
}
= do
-- Template Haskell used?
th_used <- readIORef th_var
let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
-- M.hi-boot can be in the imp_dep_mods, but we must remove
-- it before recording the modules on which this one depends!
-- (We want to retain M.hi-boot in imp_dep_mods so that
-- loadHiBootInterface can see if M's direct imports depend
-- on M.hi-boot, and hence that we should do the hi-boot consistency
-- check.)
pkgs | th_used = insertList thPackageKey (imp_dep_pkgs imports)
| otherwise = imp_dep_pkgs imports
-- Set the packages required to be Safe according to Safe Haskell.
-- See Note [RnNames . Tracking Trust Transitively]
sorted_pkgs = sortBy stablePackageKeyCmp pkgs
trust_pkgs = imp_trust_pkgs imports
dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods,
dep_pkgs = dep_pkgs',
dep_orphs = sortBy stableModuleCmp (imp_orphs imports),
dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
-- sort to get into canonical order
-- NB. remember to use lexicographic ordering
mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
-> NameSet -> Bool -> Dependencies -> GlobalRdrEnv
-> NameEnv FixItem -> Warnings -> HpcInfo
-> ImportedMods -> Bool
-> [FilePath]
-> SafeHaskellMode
-> ModDetails
-> IO (Messages, Maybe (ModIface, Bool))
mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names used_th deps rdr_env fix_env src_warns
hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode
ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
md_rules = rules,
md_anns = anns,
md_vect_info = vect_info,
md_types = type_env,
md_exports = exports }
-- NB: notice that mkIface does not look at the bindings
-- only at the TypeEnv. The previous Tidy phase has
-- put exactly the info into the TypeEnv that we want
-- to expose in the interface
= do
usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
let entities = typeEnvElts type_env
decls = [ tyThingToIfaceDecl entity
| entity <- entities,
let name = getName entity,
not (isImplicitTyThing entity),
-- No implicit Ids and class tycons in the interface file
not (isWiredInName name),
-- Nor wired-in things; the compiler knows about them anyhow
nameIsLocalOrFrom this_mod name ]
-- Sigh: see Note [Root-main Id] in TcRnDriver
fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
warns = src_warns
iface_rules = map (coreRuleToIfaceRule this_mod) rules
iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts
iface_fam_insts = map famInstToIfaceFamInst fam_insts
iface_vect_info = flattenVectInfo vect_info
trust_info = setSafeMode safe_mode
annotations = map mkIfaceAnnotation anns
sig_of = getSigOf dflags (moduleName this_mod)
intermediate_iface = ModIface {
mi_module = this_mod,
mi_sig_of = sig_of,
mi_boot = is_boot,
mi_deps = deps,
mi_usages = usages,
mi_exports = mkIfaceExports exports,
-- Sort these lexicographically, so that
-- the result is stable across compilations
mi_insts = sortBy cmp_inst iface_insts,
mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts,
mi_rules = sortBy cmp_rule iface_rules,
mi_vect_info = iface_vect_info,
mi_fixities = fixities,
mi_warns = warns,
mi_anns = annotations,
mi_globals = maybeGlobalRdrEnv rdr_env,
-- Left out deliberately: filled in by addFingerprints
mi_iface_hash = fingerprint0,
mi_mod_hash = fingerprint0,
mi_flag_hash = fingerprint0,
mi_exp_hash = fingerprint0,
mi_used_th = used_th,
mi_orphan_hash = fingerprint0,
mi_orphan = False, -- Always set by addFingerprints, but
-- it's a strict field, so we can't omit it.
mi_finsts = False, -- Ditto
mi_decls = deliberatelyOmitted "decls",
mi_hash_fn = deliberatelyOmitted "hash_fn",
mi_hpc = isHpcUsed hpc_info,
mi_trust = trust_info,
mi_trust_pkg = pkg_trust_req,
-- And build the cached values
mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities }
(new_iface, no_change_at_all)
<- {-# SCC "versioninfo" #-}
addFingerprints hsc_env maybe_old_fingerprint
intermediate_iface decls
-- Warn about orphans
-- See Note [Orphans and auto-generated rules]
let warn_orphs = wopt Opt_WarnOrphans dflags
warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags
orph_warnings --- Laziness means no work done unless -fwarn-orphans
| warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
| otherwise = emptyBag
errs_and_warns = (orph_warnings, emptyBag)
unqual = mkPrintUnqualified dflags rdr_env
inst_warns = listToBag [ instOrphWarn dflags unqual d
| (d,i) <- insts `zip` iface_insts
, isOrphan (ifInstOrph i) ]
rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r
| r <- iface_rules
, isOrphan (ifRuleOrph r)
, if ifRuleAuto r then warn_auto_orphs
else warn_orphs ]
if errorsFound dflags errs_and_warns
then return ( errs_and_warns, Nothing )
else do
-- Debug printing
dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
(pprModIface new_iface)
-- bug #1617: on reload we weren't updating the PrintUnqualified
-- correctly. This stems from the fact that the interface had
-- not changed, so addFingerprints returns the old ModIface
-- with the old GlobalRdrEnv (mi_globals).
let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
return (errs_and_warns, Just (final_iface, no_change_at_all))
where
cmp_rule = comparing ifRuleName
-- Compare these lexicographically by OccName, *not* by unique,
-- because the latter is not stable across compilations:
cmp_inst = comparing (nameOccName . ifDFun)
cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
dflags = hsc_dflags hsc_env
-- We only fill in mi_globals if the module was compiled to byte
-- code. Otherwise, the compiler may not have retained all the
-- top-level bindings and they won't be in the TypeEnv (see
-- Desugar.addExportFlagsAndRules). The mi_globals field is used
-- by GHCi to decide whether the module has its full top-level
-- scope available. (#5534)
maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
maybeGlobalRdrEnv rdr_env
| targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
| otherwise = Nothing
deliberatelyOmitted :: String -> a
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
ifFamInstTcName = ifFamInstFam
flattenVectInfo (VectInfo { vectInfoVar = vVar
, vectInfoTyCon = vTyCon
, vectInfoParallelVars = vParallelVars
, vectInfoParallelTyCons = vParallelTyCons
}) =
IfaceVectInfo
{ ifaceVectInfoVar = [Var.varName v | (v, _ ) <- varEnvElts vVar]
, ifaceVectInfoTyCon = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
, ifaceVectInfoTyConReuse = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
, ifaceVectInfoParallelVars = [Var.varName v | v <- varSetElems vParallelVars]
, ifaceVectInfoParallelTyCons = nameSetElems vParallelTyCons
}
-----------------------------
writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
writeIfaceFile dflags hi_file_path new_iface
= do createDirectoryIfMissing True (takeDirectory hi_file_path)
writeBinIface dflags hi_file_path new_iface
-- -----------------------------------------------------------------------------
-- Look up parents and versions of Names
-- This is like a global version of the mi_hash_fn field in each ModIface.
-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
-- the parent and version info.
mkHashFun
:: HscEnv -- needed to look up versions
-> ExternalPackageState -- ditto
-> (Name -> Fingerprint)
mkHashFun hsc_env eps
= \name ->
let
mod = ASSERT2( isExternalName name, ppr name ) nameModule name
occ = nameOccName name
iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
pprPanic "lookupVers2" (ppr mod <+> ppr occ)
in
snd (mi_hash_fn iface occ `orElse`
pprPanic "lookupVers1" (ppr mod <+> ppr occ))
where
hpt = hsc_HPT hsc_env
pit = eps_PIT eps
-- ---------------------------------------------------------------------------
-- Compute fingerprints for the interface
addFingerprints
:: HscEnv
-> Maybe Fingerprint -- the old fingerprint, if any
-> ModIface -- The new interface (lacking decls)
-> [IfaceDecl] -- The new decls
-> IO (ModIface, -- Updated interface
Bool) -- True <=> no changes at all;
-- no need to write Iface
addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
= do
eps <- hscEPS hsc_env
let
-- The ABI of a declaration represents everything that is made
-- visible about the declaration that a client can depend on.
-- see IfaceDeclABI below.
declABI :: IfaceDecl -> IfaceDeclABI
declABI decl = (this_mod, decl, extras)
where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts
non_orph_fis decl
edges :: [(IfaceDeclABI, Unique, [Unique])]
edges = [ (abi, getUnique (ifName decl), out)
| decl <- new_decls
, let abi = declABI decl
, let out = localOccs $ freeNamesDeclABI abi
]
name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
localOccs = map (getUnique . getParent . getOccName)
. filter ((== this_mod) . name_module)
. nameSetElems
where getParent occ = lookupOccEnv parent_map occ `orElse` occ
-- maps OccNames to their parents in the current module.
-- e.g. a reference to a constructor must be turned into a reference
-- to the TyCon for the purposes of calculating dependencies.
parent_map :: OccEnv OccName
parent_map = foldr extend emptyOccEnv new_decls
where extend d env =
extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
where n = ifName d
-- strongly-connected groups of declarations, in dependency order
groups = stronglyConnCompFromEdgedVertices edges
global_hash_fn = mkHashFun hsc_env eps
-- how to output Names when generating the data to fingerprint.
-- Here we want to output the fingerprint for each top-level
-- Name, whether it comes from the current module or another
-- module. In this way, the fingerprint for a declaration will
-- change if the fingerprint for anything it refers to (transitively)
-- changes.
mk_put_name :: (OccEnv (OccName,Fingerprint))
-> BinHandle -> Name -> IO ()
mk_put_name local_env bh name
| isWiredInName name = putNameLiterally bh name
-- wired-in names don't have fingerprints
| otherwise
= ASSERT2( isExternalName name, ppr name )
let hash | nameModule name /= this_mod = global_hash_fn name
| otherwise = snd (lookupOccEnv local_env (getOccName name)
`orElse` pprPanic "urk! lookup local fingerprint"
(ppr name)) -- (undefined,fingerprint0))
-- This panic indicates that we got the dependency
-- analysis wrong, because we needed a fingerprint for
-- an entity that wasn't in the environment. To debug
-- it, turn the panic into a trace, uncomment the
-- pprTraces below, run the compile again, and inspect
-- the output and the generated .hi file with
-- --show-iface.
in put_ bh hash
-- take a strongly-connected group of declarations and compute
-- its fingerprint.
fingerprint_group :: (OccEnv (OccName,Fingerprint),
[(Fingerprint,IfaceDecl)])
-> SCC IfaceDeclABI
-> IO (OccEnv (OccName,Fingerprint),
[(Fingerprint,IfaceDecl)])
fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
= do let hash_fn = mk_put_name local_env
decl = abiDecl abi
-- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
hash <- computeFingerprint hash_fn abi
env' <- extend_hash_env local_env (hash,decl)
return (env', (hash,decl) : decls_w_hashes)
fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
= do let decls = map abiDecl abis
local_env1 <- foldM extend_hash_env local_env
(zip (repeat fingerprint0) decls)
let hash_fn = mk_put_name local_env1
-- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
let stable_abis = sortBy cmp_abiNames abis
-- put the cycle in a canonical order
hash <- computeFingerprint hash_fn stable_abis
let pairs = zip (repeat hash) decls
local_env2 <- foldM extend_hash_env local_env pairs
return (local_env2, pairs ++ decls_w_hashes)
-- we have fingerprinted the whole declaration, but we now need
-- to assign fingerprints to all the OccNames that it binds, to
-- use when referencing those OccNames in later declarations.
--
extend_hash_env :: OccEnv (OccName,Fingerprint)
-> (Fingerprint,IfaceDecl)
-> IO (OccEnv (OccName,Fingerprint))
extend_hash_env env0 (hash,d) = do
return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
(ifaceDeclFingerprints hash d))
--
(local_env, decls_w_hashes) <-
foldM fingerprint_group (emptyOccEnv, []) groups
-- when calculating fingerprints, we always need to use canonical
-- ordering for lists of things. In particular, the mi_deps has various
-- lists of modules and suchlike, so put these all in canonical order:
let sorted_deps = sortDependencies (mi_deps iface0)
-- the export hash of a module depends on the orphan hashes of the
-- orphan modules below us in the dependency tree. This is the way
-- that changes in orphans get propagated all the way up the
-- dependency tree. We only care about orphan modules in the current
-- package, because changes to orphans outside this package will be
-- tracked by the usage on the ABI hash of package modules that we import.
let orph_mods
= filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]
. filter ((== this_pkg) . modulePackageKey)
$ dep_orphs sorted_deps
dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
-- Note [Do not update EPS with your own hi-boot]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- (See also Trac #10182). When your hs-boot file includes an orphan
-- instance declaration, you may find that the dep_orphs of a module you
-- import contains reference to yourself. DO NOT actually load this module
-- or add it to the orphan hashes: you're going to provide the orphan
-- instances yourself, no need to consult hs-boot; if you do load the
-- interface into EPS, you will see a duplicate orphan instance.
orphan_hash <- computeFingerprint (mk_put_name local_env)
(map ifDFun orph_insts, orph_rules, orph_fis)
-- the export list hash doesn't depend on the fingerprints of
-- the Names it mentions, only the Names themselves, hence putNameLiterally.
export_hash <- computeFingerprint putNameLiterally
(mi_exports iface0,
orphan_hash,
dep_orphan_hashes,
dep_pkgs (mi_deps iface0),
-- dep_pkgs: see "Package Version Changes" on
-- wiki/Commentary/Compiler/RecompilationAvoidance
mi_trust iface0)
-- Make sure change of Safe Haskell mode causes recomp.
-- put the declarations in a canonical order, sorted by OccName
let sorted_decls = Map.elems $ Map.fromList $
[(ifName d, e) | e@(_, d) <- decls_w_hashes]
-- the flag hash depends on:
-- - (some of) dflags
-- it returns two hashes, one that shouldn't change
-- the abi hash and one that should
flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
-- the ABI hash depends on:
-- - decls
-- - export list
-- - orphans
-- - deprecations
-- - vect info
-- - flag abi hash
mod_hash <- computeFingerprint putNameLiterally
(map fst sorted_decls,
export_hash, -- includes orphan_hash
mi_warns iface0,
mi_vect_info iface0)
-- The interface hash depends on:
-- - the ABI hash, plus
-- - the module level annotations,
-- - usages
-- - deps (home and external packages, dependent files)
-- - hpc
iface_hash <- computeFingerprint putNameLiterally
(mod_hash,
ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache
mi_usages iface0,
sorted_deps,
mi_hpc iface0)
let
no_change_at_all = Just iface_hash == mb_old_fingerprint
final_iface = iface0 {
mi_mod_hash = mod_hash,
mi_iface_hash = iface_hash,
mi_exp_hash = export_hash,
mi_orphan_hash = orphan_hash,
mi_flag_hash = flag_hash,
mi_orphan = not ( all ifRuleAuto orph_rules
-- See Note [Orphans and auto-generated rules]
&& null orph_insts
&& null orph_fis
&& isNoIfaceVectInfo (mi_vect_info iface0)),
mi_finsts = not . null $ mi_fam_insts iface0,
mi_decls = sorted_decls,
mi_hash_fn = lookupOccEnv local_env }
--
return (final_iface, no_change_at_all)
where
this_mod = mi_module iface0
dflags = hsc_dflags hsc_env
this_pkg = thisPackage dflags
(non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
(non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
(non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)
fix_fn = mi_fix_fn iface0
ann_fn = mkIfaceAnnCache (mi_anns iface0)
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes hsc_env mods = do
eps <- hscEPS hsc_env
let
hpt = hsc_HPT hsc_env
pit = eps_PIT eps
dflags = hsc_dflags hsc_env
get_orph_hash mod =
case lookupIfaceByModule dflags hpt pit mod of
Nothing -> pprPanic "moduleOrphanHash" (ppr mod)
Just iface -> mi_orphan_hash iface
--
return (map get_orph_hash mods)
sortDependencies :: Dependencies -> Dependencies
sortDependencies d
= Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
dep_pkgs = sortBy (stablePackageKeyCmp `on` fst) (dep_pkgs d),
dep_orphs = sortBy stableModuleCmp (dep_orphs d),
dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
-- | Creates cached lookup for the 'mi_anns' field of ModIface
-- Hackily, we use "module" as the OccName for any module-level annotations
mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
mkIfaceAnnCache anns
= \n -> lookupOccEnv env n `orElse` []
where
pair (IfaceAnnotation target value) =
(case target of
NamedTarget occn -> occn
ModuleTarget _ -> mkVarOcc "module"
, [value])
-- flipping (++), so the first argument is always short
env = mkOccEnv_C (flip (++)) (map pair anns)
{-
Note [Orphans and auto-generated rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we specialise an INLINEABLE function, or when we have
-fspecialise-aggressively, we auto-generate RULES that are orphans.
We don't want to warn about these, at least not by default, or we'd
generate a lot of warnings. Hence -fwarn-auto-orphans.
Indeed, we don't even treat the module as an oprhan module if it has
auto-generated *rule* orphans. Orphan modules are read every time we
compile, so they are pretty obtrusive and slow down every compilation,
even non-optimised ones. (Reason: for type class instances it's a
type correctness issue.) But specialisation rules are strictly for
*optimisation* only so it's fine not to read the interface.
What this means is that a SPEC rules from auto-specialisation in
module M will be used in other modules only if M.hi has been read for
some other reason, which is actually pretty likely.
************************************************************************
* *
The ABI of an IfaceDecl
* *
************************************************************************
Note [The ABI of an IfaceDecl]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The ABI of a declaration consists of:
(a) the full name of the identifier (inc. module and package,
because these are used to construct the symbol name by which
the identifier is known externally).
(b) the declaration itself, as exposed to clients. That is, the
definition of an Id is included in the fingerprint only if
it is made available as an unfolding in the interface.
(c) the fixity of the identifier
(d) for Ids: rules
(e) for classes: instances, fixity & rules for methods
(f) for datatypes: instances, fixity & rules for constrs
Items (c)-(f) are not stored in the IfaceDecl, but instead appear
elsewhere in the interface file. But they are *fingerprinted* with
the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
and fingerprinting that as part of the declaration.
-}
type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
data IfaceDeclExtras
= IfaceIdExtras IfaceIdExtras
| IfaceDataExtras
Fixity -- Fixity of the tycon itself
[IfaceInstABI] -- Local class and family instances of this tycon
-- See Note [Orphans] in InstEnv
[AnnPayload] -- Annotations of the type itself
[IfaceIdExtras] -- For each constructor: fixity, RULES and annotations
| IfaceClassExtras
Fixity -- Fixity of the class itself
[IfaceInstABI] -- Local instances of this class *or*
-- of its associated data types
-- See Note [Orphans] in InstEnv
[AnnPayload] -- Annotations of the type itself
[IfaceIdExtras] -- For each class method: fixity, RULES and annotations
| IfaceSynonymExtras Fixity [AnnPayload]
| IfaceFamilyExtras Fixity [IfaceInstABI] [AnnPayload]
| IfaceOtherDeclExtras
data IfaceIdExtras
= IdExtras
Fixity -- Fixity of the Id
[IfaceRule] -- Rules for the Id
[AnnPayload] -- Annotations for the Id
-- When hashing a class or family instance, we hash only the
-- DFunId or CoAxiom, because that depends on all the
-- information about the instance.
--
type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance
abiDecl :: IfaceDeclABI -> IfaceDecl
abiDecl (_, decl, _) = decl
cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare`
ifName (abiDecl abi2)
freeNamesDeclABI :: IfaceDeclABI -> NameSet
freeNamesDeclABI (_mod, decl, extras) =
freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras
freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
freeNamesDeclExtras (IfaceIdExtras id_extras)
= freeNamesIdExtras id_extras
freeNamesDeclExtras (IfaceDataExtras _ insts _ subs)
= unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
freeNamesDeclExtras (IfaceClassExtras _ insts _ subs)
= unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
freeNamesDeclExtras (IfaceSynonymExtras _ _)
= emptyNameSet
freeNamesDeclExtras (IfaceFamilyExtras _ insts _)
= mkNameSet insts
freeNamesDeclExtras IfaceOtherDeclExtras
= emptyNameSet
freeNamesIdExtras :: IfaceIdExtras -> NameSet
freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)
instance Outputable IfaceDeclExtras where
ppr IfaceOtherDeclExtras = Outputable.empty
ppr (IfaceIdExtras extras) = ppr_id_extras extras
ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]
ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
ppr_id_extras_s stuff]
ppr (IfaceClassExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
ppr_id_extras_s stuff]
ppr_insts :: [IfaceInstABI] -> SDoc
ppr_insts _ = ptext (sLit "<insts>")
ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)
ppr_id_extras :: IfaceIdExtras -> SDoc
ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)
-- This instance is used only to compute fingerprints
instance Binary IfaceDeclExtras where
get _bh = panic "no get for IfaceDeclExtras"
put_ bh (IfaceIdExtras extras) = do
putByte bh 1; put_ bh extras
put_ bh (IfaceDataExtras fix insts anns cons) = do
putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons
put_ bh (IfaceClassExtras fix insts anns methods) = do
putByte bh 3; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh methods
put_ bh (IfaceSynonymExtras fix anns) = do
putByte bh 4; put_ bh fix; put_ bh anns
put_ bh (IfaceFamilyExtras fix finsts anns) = do
putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns
put_ bh IfaceOtherDeclExtras = putByte bh 6
instance Binary IfaceIdExtras where
get _bh = panic "no get for IfaceIdExtras"
put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }
declExtras :: (OccName -> Fixity)
-> (OccName -> [AnnPayload])
-> OccEnv [IfaceRule]
-> OccEnv [IfaceClsInst]
-> OccEnv [IfaceFamInst]
-> IfaceDecl
-> IfaceDeclExtras
declExtras fix_fn ann_fn rule_env inst_env fi_env decl
= case decl of
IfaceId{} -> IfaceIdExtras (id_extras n)
IfaceData{ifCons=cons} ->
IfaceDataExtras (fix_fn n)
(map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
map ifDFun (lookupOccEnvL inst_env n))
(ann_fn n)
(map (id_extras . ifConOcc) (visibleIfConDecls cons))
IfaceClass{ifSigs=sigs, ifATs=ats} ->
IfaceClassExtras (fix_fn n)
(map ifDFun $ (concatMap at_extras ats)
++ lookupOccEnvL inst_env n)
-- Include instances of the associated types
-- as well as instances of the class (Trac #5147)
(ann_fn n)
[id_extras op | IfaceClassOp op _ _ <- sigs]
IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)
(ann_fn n)
IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)
(map ifFamInstAxiom (lookupOccEnvL fi_env n))
(ann_fn n)
_other -> IfaceOtherDeclExtras
where
n = ifName decl
id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)
at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (ifName decl)
lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
lookupOccEnvL env k = lookupOccEnv env k `orElse` []
-- used when we want to fingerprint a structure without depending on the
-- fingerprints of external Names that it refers to.
putNameLiterally :: BinHandle -> Name -> IO ()
putNameLiterally bh name = ASSERT( isExternalName name )
do
put_ bh $! nameModule name
put_ bh $! nameOccName name
{-
-- for testing: use the md5sum command to generate fingerprints and
-- compare the results against our built-in version.
fp' <- oldMD5 dflags bh
if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
else return fp
oldMD5 dflags bh = do
tmp <- newTempName dflags "bin"
writeBinMem bh tmp
tmp2 <- newTempName dflags "md5"
let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
r <- system cmd
case r of
ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)
ExitSuccess -> do
hash_str <- readFile tmp2
return $! readHexFingerprint hash_str
-}
instOrphWarn :: DynFlags -> PrintUnqualified -> ClsInst -> WarnMsg
instOrphWarn dflags unqual inst
= mkWarnMsg dflags (getSrcSpan inst) unqual $
hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
$$ text "To avoid this"
$$ nest 4 (vcat possibilities)
where
possibilities =
text "move the instance declaration to the module of the class or of the type, or" :
text "wrap the type with a newtype and declare the instance on the new type." :
[]
ruleOrphWarn :: DynFlags -> PrintUnqualified -> Module -> IfaceRule -> WarnMsg
ruleOrphWarn dflags unqual mod rule
= mkWarnMsg dflags silly_loc unqual $
ptext (sLit "Orphan rule:") <+> ppr rule
where
silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
-- We don't have a decent SrcSpan for a Rule, not even the CoreRule
-- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
----------------------
-- mkOrphMap partitions instance decls or rules into
-- (a) an OccEnv for ones that are not orphans,
-- mapping the local OccName to a list of its decls
-- (b) a list of orphan decls
mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
-> [decl] -- Sorted into canonical order
-> (OccEnv [decl], -- Non-orphan decls associated with their key;
-- each sublist in canonical order
[decl]) -- Orphan decls; in canonical order
mkOrphMap get_key decls
= foldl go (emptyOccEnv, []) decls
where
go (non_orphs, orphs) d
| NotOrphan occ <- get_key d
= (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
| otherwise = (non_orphs, d:orphs)
{-
************************************************************************
* *
Keeping track of what we've slurped, and fingerprints
* *
************************************************************************
-}
mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage]
mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
= do
eps <- hscEPS hsc_env
hashes <- mapM getFileHash dependent_files
let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
dir_imp_mods used_names
let usages = mod_usages ++ [ UsageFile { usg_file_path = f
, usg_file_hash = hash }
| (f, hash) <- zip dependent_files hashes ]
usages `seqList` return usages
-- seq the list of Usages returned: occasionally these
-- don't get evaluated for a while and we can end up hanging on to
-- the entire collection of Ifaces.
mk_mod_usage_info :: PackageIfaceTable
-> HscEnv
-> Module
-> ImportedMods
-> NameSet
-> [Usage]
mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
= mapMaybe mkUsage usage_mods
where
hpt = hsc_HPT hsc_env
dflags = hsc_dflags hsc_env
this_pkg = thisPackage dflags
used_mods = moduleEnvKeys ent_map
dir_imp_mods = moduleEnvKeys direct_imports
all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
usage_mods = sortBy stableModuleCmp all_mods
-- canonical order is imported, to avoid interface-file
-- wobblage.
-- ent_map groups together all the things imported and used
-- from a particular module
ent_map :: ModuleEnv [OccName]