Testsuite: T3333 still fails on non-linux statically linked ghci (#3333)
[ghc.git] / compiler / backpack / ShPackageKey.hs
1 {-# LANGUAGE CPP #-}
2 module ShPackageKey(
3 ShFreeHoles,
4 calcModuleFreeHoles,
5
6 newPackageKey,
7 newPackageKeyWithScope,
8 lookupPackageKey,
9
10 generalizeHoleModule,
11 canonicalizeModule,
12
13 pprPackageKey
14 ) where
15
16 #include "HsVersions.h"
17
18 import Module
19 import Packages
20 import Encoding
21 import FastString
22 import UniqFM
23 import UniqSet
24 import Outputable
25 import Util
26 import DynFlags
27
28 import System.IO.Unsafe ( unsafePerformIO )
29 import Control.Monad
30 import Data.IORef
31 import GHC.Fingerprint
32 import Data.List
33 import Data.Function
34
35 -- NB: didn't put this in Module, that seems a bit too low in the
36 -- hierarchy, need to refer to DynFlags
37
38 {-
39 ************************************************************************
40 * *
41 Package Keys
42 * *
43 ************************************************************************
44 -}
45
46 -- Note: [PackageKey cache]
47 -- ~~~~~~~~~~~~~~~~~~~~~~~~
48 -- The built-in PackageKey type (used by Module, Name, etc)
49 -- records the instantiation of the package as an MD5 hash
50 -- which is not reversible without some extra information.
51 -- However, the shape merging process requires us to be able
52 -- to substitute Module occurrences /inside/ the package key.
53 --
54 -- Thus, we maintain the invariant: for every PackageKey
55 -- in our system, either:
56 --
57 -- 1. It is in the installed package database (lookupPackage)
58 -- so we can lookup the recorded instantiatedWith
59 -- 2. We've recorded the associated mapping in the
60 -- PackageKeyCache.
61 --
62 -- A PackageKey can be expanded into a ShPackageKey which has
63 -- the instance mapping. In the mapping, we don't bother
64 -- expanding a 'Module'; depending on 'shPackageKeyFreeHoles',
65 -- it may not be necessary to do a substitution (you only
66 -- need to drill down when substituing HOLE:H if H is in scope.
67
68 -- Note: [Module name in scope set]
69 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
70 -- Similar to InScopeSet, ShFreeHoles is an optimization that
71 -- allows us to avoid expanding a PackageKey into an ShPackageKey
72 -- if there isn't actually anything in the module expression that
73 -- we can substitute.
74
75 -- | Given a Name or Module, the 'ShFreeHoles' contains the set
76 -- of free variables, i.e. HOLE:A modules, which may be substituted.
77 -- If this set is empty no substitutions are possible.
78 type ShFreeHoles = UniqSet ModuleName
79
80 -- | Calculate the free holes of a 'Module'.
81 calcModuleFreeHoles :: DynFlags -> Module -> IO ShFreeHoles
82 calcModuleFreeHoles dflags m
83 | modulePackageKey m == holePackageKey = return (unitUniqSet (moduleName m))
84 | otherwise = do
85 shpk <- lookupPackageKey dflags (modulePackageKey m)
86 return $ case shpk of
87 ShDefinitePackageKey{} -> emptyUniqSet
88 ShPackageKey{ shPackageKeyFreeHoles = in_scope } -> in_scope
89
90 -- | Calculate the free holes of the hole map @[('ModuleName', 'Module')]@.
91 calcInstsFreeHoles :: DynFlags -> [(ModuleName, Module)] -> IO ShFreeHoles
92 calcInstsFreeHoles dflags insts =
93 fmap unionManyUniqSets (mapM (calcModuleFreeHoles dflags . snd) insts)
94
95 -- | Given a 'UnitName', a 'LibraryName', and sorted mapping of holes to
96 -- their implementations, compute the 'PackageKey' associated with it, as well
97 -- as the recursively computed 'ShFreeHoles' of holes that may be substituted.
98 newPackageKeyWithScope :: DynFlags
99 -> UnitName
100 -> LibraryName
101 -> [(ModuleName, Module)]
102 -> IO (PackageKey, ShFreeHoles)
103 newPackageKeyWithScope dflags pn vh insts = do
104 fhs <- calcInstsFreeHoles dflags insts
105 pk <- newPackageKey' dflags (ShPackageKey pn vh insts fhs)
106 return (pk, fhs)
107
108 -- | Given a 'UnitName' and sorted mapping of holes to
109 -- their implementations, compute the 'PackageKey' associated with it.
110 -- (Analogous to 'newGlobalBinder').
111 newPackageKey :: DynFlags
112 -> UnitName
113 -> LibraryName
114 -> [(ModuleName, Module)]
115 -> IO PackageKey
116 newPackageKey dflags pn vh insts = do
117 (pk, _) <- newPackageKeyWithScope dflags pn vh insts
118 return pk
119
120 -- | Given a 'ShPackageKey', compute the 'PackageKey' associated with it.
121 -- This function doesn't calculate the 'ShFreeHoles', because it is
122 -- provided with 'ShPackageKey'.
123 newPackageKey' :: DynFlags -> ShPackageKey -> IO PackageKey
124 newPackageKey' _ (ShDefinitePackageKey pk) = return pk
125 newPackageKey' dflags
126 shpk@(ShPackageKey pn vh insts fhs) = do
127 ASSERTM( fmap (==fhs) (calcInstsFreeHoles dflags insts) )
128 let pk = mkPackageKey pn vh insts
129 pkt_var = pkgKeyCache dflags
130 pk_cache <- readIORef pkt_var
131 let consistent pk_cache = maybe True (==shpk) (lookupUFM pk_cache pk)
132 MASSERT( consistent pk_cache )
133 when (not (elemUFM pk pk_cache)) $
134 atomicModifyIORef' pkt_var (\pk_cache ->
135 -- Could race, but it's guaranteed to be the same
136 ASSERT( consistent pk_cache ) (addToUFM pk_cache pk shpk, ()))
137 return pk
138
139 -- | Given a 'PackageKey', reverse lookup the 'ShPackageKey' associated
140 -- with it. This only gives useful information for keys which are
141 -- created using 'newPackageKey' or the associated functions, or that are
142 -- already in the installed package database, since we generally cannot reverse
143 -- MD5 hashes.
144 lookupPackageKey :: DynFlags
145 -> PackageKey
146 -> IO ShPackageKey
147 lookupPackageKey dflags pk
148 | pk `elem` wiredInPackageKeys
149 || pk == mainPackageKey
150 || pk == holePackageKey
151 = return (ShDefinitePackageKey pk)
152 | otherwise = do
153 let pkt_var = pkgKeyCache dflags
154 pk_cache <- readIORef pkt_var
155 case lookupUFM pk_cache pk of
156 Just r -> return r
157 _ -> return (ShDefinitePackageKey pk)
158
159 pprPackageKey :: PackageKey -> SDoc
160 pprPackageKey pk = sdocWithDynFlags $ \dflags ->
161 -- name cache is a memotable
162 let shpk = unsafePerformIO (lookupPackageKey dflags pk)
163 in case shpk of
164 shpk@ShPackageKey{} ->
165 ppr (shPackageKeyUnitName shpk) <>
166 parens (hsep
167 (punctuate comma [ ppUnless (moduleName m == modname)
168 (ppr modname <+> text "->")
169 <+> ppr m
170 | (modname, m) <- shPackageKeyInsts shpk]))
171 <> ifPprDebug (braces (ftext (packageKeyFS pk)))
172 ShDefinitePackageKey pk -> ftext (packageKeyFS pk)
173
174 -- NB: newPackageKey and lookupPackageKey are mutually recursive; this
175 -- recursion is guaranteed to bottom out because you can't set up cycles
176 -- of PackageKeys.
177
178
179 {-
180 ************************************************************************
181 * *
182 Package key hashing
183 * *
184 ************************************************************************
185 -}
186
187 -- | Generates a 'PackageKey'. Don't call this directly; you probably
188 -- want to cache the result.
189 mkPackageKey :: UnitName
190 -> LibraryName
191 -> [(ModuleName, Module)] -- hole instantiations
192 -> PackageKey
193 mkPackageKey (UnitName fsUnitName)
194 (LibraryName fsLibraryName) unsorted_holes =
195 -- NB: don't use concatFS here, it's not much of an improvement
196 fingerprintPackageKey . fingerprintString $
197 unpackFS fsUnitName ++ "\n" ++
198 unpackFS fsLibraryName ++ "\n" ++
199 concat [ moduleNameString m
200 ++ " " ++ packageKeyString (modulePackageKey b)
201 ++ ":" ++ moduleNameString (moduleName b) ++ "\n"
202 | (m, b) <- sortBy (stableModuleNameCmp `on` fst) unsorted_holes]
203
204 -- | Generalize a 'Module' into one where all the holes are indefinite.
205 -- @p(A -> ...):C@ generalizes to @p(A -> HOLE:A):C@. Useful when
206 -- you need to figure out if you've already type-checked the generalized
207 -- version of this module, so you don't have to do the whole rigamarole.
208 generalizeHoleModule :: DynFlags -> Module -> IO Module
209 generalizeHoleModule dflags m = do
210 pk <- generalizeHolePackageKey dflags (modulePackageKey m)
211 return (mkModule pk (moduleName m))
212
213 -- | Generalize a 'PackageKey' into one where all the holes are indefinite.
214 -- @p(A -> q():A) generalizes to p(A -> HOLE:A)@.
215 generalizeHolePackageKey :: DynFlags -> PackageKey -> IO PackageKey
216 generalizeHolePackageKey dflags pk = do
217 shpk <- lookupPackageKey dflags pk
218 case shpk of
219 ShDefinitePackageKey _ -> return pk
220 ShPackageKey { shPackageKeyUnitName = pn,
221 shPackageKeyLibraryName = vh,
222 shPackageKeyInsts = insts0 }
223 -> let insts = map (\(x, _) -> (x, mkModule holePackageKey x)) insts0
224 in newPackageKey dflags pn vh insts
225
226 -- | Canonicalize a 'Module' so that it uniquely identifies a module.
227 -- For example, @p(A -> M):A@ canonicalizes to @M@. Useful for making
228 -- sure the interface you've loaded as the right @mi_module@.
229 canonicalizeModule :: DynFlags -> Module -> IO Module
230 canonicalizeModule dflags m = do
231 let pk = modulePackageKey m
232 shpk <- lookupPackageKey dflags pk
233 return $ case shpk of
234 ShPackageKey { shPackageKeyInsts = insts }
235 | Just m' <- lookup (moduleName m) insts -> m'
236 _ -> m
237
238 fingerprintPackageKey :: Fingerprint -> PackageKey
239 fingerprintPackageKey (Fingerprint a b)
240 = stringToPackageKey (toBase62Padded a ++ toBase62Padded b)
241 -- See Note [Base 62 encoding 128-bit integers]