blob: 21d4a964647231217fb9ba3b7fe331b75572e7ee (
plain)
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
|
-- {-# LANGUAGE StandaloneDeriving #-}
-- -----------------------------------------------------------------------------
-- | This module manages storing the various GHC option flags in a modules
-- interface file as part of the recompilation checking infrastructure.
--
module FlagChecker (
fingerprintDynFlags
) where
import Binary
import BinIface ()
import DynFlags
import HscTypes
import Name
import Fingerprint
-- import Data.List (sort)
{-
Note [DynFlags Hash]
~~~~~~~~~~~~~~~~~~~
We only hash fields from DynFlags that are of high importance as they stop
link and build errors occurring (e.g the '--main-is' flag, see trac #437).
An alternative design would be to return two fingerprints where the first one
encodes flags that if different mean that the module itself should be
recompiled but only this module. The second fingerprint is for flags that mean
that not only the module itself should be recompiled but also modules that
depend on it. (i.e the second fingerprint affects the modules ABI).
This design hasn't been implemented as it's tricky to fit in with the current
recompilation manager and its not sure how beneficial it is.
-}
-- | Produce a fingerprint of a @DynFlags@ value. We only base
-- the finger print on important fields in @DynFlags@ so that
-- the recompilation checker can use this fingerprint.
fingerprintDynFlags :: DynFlags -> (BinHandle -> Name -> IO ()) -> IO Fingerprint
fingerprintDynFlags dflags nameio =
let -- DriverPipeline.getLinkInfo handles this info I believe
-- rtsopts = (rtsOptsEnabled dflags, rtsOpts dflags)
-- Probably not a good idea
-- optlvl = optLevel dflags
mainis = (mainModIs dflags, mainFunIs dflags)
-- pkgopts = (thisPackage dflags, sort $ packageFlags dflags)
safeHs = setSafeMode $ safeHaskell dflags
-- oflags = sort $ filter filterOFlags $ flags dflags
-- eflags = sort $ filter filterEFlags $ extensionFlags dflags
flagOpts = (mainis, safeHs)
in computeFingerprint nameio flagOpts
{-
-- | Should the @DynFlag@ be included in the fingerprint?
filterOFlags :: DynFlag -> Bool
filterOFlags Opt_EnableRewriteRules = True
filterOFlags Opt_Vectorise = True
filterOFlags Opt_IgnoreInterfacePragmas = True
filterOFlags Opt_OmitInterfacePragmas = True
filterOFlags Opt_ExposeAllUnfoldings = True
filterOFlags Opt_ReadUserPackageConf = True
filterOFlags Opt_NoHsMain = True
filterOFlags Opt_SSE2 = True
filterOFlags Opt_SSE4_2 = True
filterOFlags Opt_PackageTrust = True
filterOFlags _ = False
-- | Should the @ExtensionFlag@ be included in the fingerprint?
filterEFlags :: ExtensionFlag -> Bool
filterEFlags Opt_ExtendedDefaultRules = True
filterEFlags Opt_InterruptibleFFI = True
filterEFlags Opt_ImplicitParams = True
filterEFlags Opt_ImplicitPrelude = True
filterEFlags Opt_OverloadedStrings = True
filterEFlags Opt_RebindableSyntax = True
filterEFlags _ = False
-}
-- -----------------------------------------------------------------------------
-- Instances needed for Binary
-- -----------------------------------------------------------------------------
{-
deriving instance Ord DynFlag
deriving instance Enum DynFlag
deriving instance Ord ExtensionFlag
deriving instance Enum ExtensionFlag
-- NOTE: We're converting from int to byte8 here, so be careful if we
-- ever get more DynFlag or ExtensionFlag constructors than 256.
instance Binary DynFlag where
put_ bh = (putByte bh . fromIntegral . fromEnum)
get bh = getByte bh >>= (return . toEnum . fromIntegral)
instance Binary ExtensionFlag where
put_ bh = (putByte bh . fromIntegral . fromEnum)
get bh = getByte bh >>= (return . toEnum . fromIntegral)
-- | RtsOptsEnabled Binary Instance
instance Binary RtsOptsEnabled where
put_ bh rtsopts =
case rtsopts of
RtsOptsNone -> putByte bh 0
RtsOptsSafeOnly -> putByte bh 1
RtsOptsAll -> putByte bh 2
get bh = do
x <- getByte bh
case x of
0 -> return RtsOptsNone
1 -> return RtsOptsSafeOnly
2 -> return RtsOptsAll
_ -> error "Unhandled RtsOptsEnabled serilization"
-- | PackageFlag Binary Instance
instance Binary PackageFlag where
put_ bh pflag =
case pflag of
(ExposePackage s) -> store 0 s
(ExposePackageId s) -> store 1 s
(HidePackage s) -> store 2 s
(IgnorePackage s) -> store 3 s
(TrustPackage s) -> store 4 s
(DistrustPackage s) -> store 5 s
where store n s = putByte bh n >> put_ bh s
get bh = do
n <- getByte bh
s <- get bh
return $ case n of
0 -> ExposePackage s
1 -> ExposePackageId s
2 -> HidePackage s
3 -> IgnorePackage s
4 -> TrustPackage s
5 -> DistrustPackage s
_ -> error "Unhandled PackageFlag serilization"
-}
|
