| ... |
... |
@@ -7,6 +7,8 @@ |
|
7
|
7
|
-- (c) The University of Glasgow 2005
|
|
8
|
8
|
--
|
|
9
|
9
|
-----------------------------------------------------------------------------
|
|
|
10
|
+{-# LANGUAGE DerivingVia #-}
|
|
|
11
|
+{-# LANGUAGE RecordWildCards #-}
|
|
10
|
12
|
|
|
11
|
13
|
module GHC.Driver.MakeFile
|
|
12
|
14
|
( doMkDependHS
|
| ... |
... |
@@ -16,47 +18,64 @@ where |
|
16
|
18
|
|
|
17
|
19
|
import GHC.Prelude
|
|
18
|
20
|
|
|
19
|
|
-import qualified GHC
|
|
20
|
|
-import GHC.Driver.Make
|
|
21
|
|
-import GHC.Driver.Monad
|
|
|
21
|
+import GHC qualified
|
|
|
22
|
+
|
|
|
23
|
+import GHC.Data.Bag (listToBag)
|
|
|
24
|
+import GHC.Data.FastString (lexicalCompareFS, unpackFS)
|
|
|
25
|
+import GHC.Data.Graph.Directed (SCC (..))
|
|
|
26
|
+import GHC.Data.OsPath (unsafeDecodeUtf, unsafeEncodeUtf)
|
|
|
27
|
+
|
|
22
|
28
|
import GHC.Driver.DynFlags
|
|
23
|
|
-import GHC.Utils.Misc
|
|
24
|
29
|
import GHC.Driver.Env
|
|
25
|
30
|
import GHC.Driver.Errors.Types
|
|
26
|
|
-import GHC.Types.UnresolvedImport
|
|
27
|
|
-import qualified GHC.SysTools as SysTools
|
|
28
|
|
-import GHC.Data.Graph.Directed ( SCC(..) )
|
|
29
|
|
-import GHC.Data.OsPath (unsafeDecodeUtf)
|
|
30
|
|
-import GHC.Utils.Outputable
|
|
31
|
|
-import GHC.Utils.Panic
|
|
32
|
|
-import GHC.Types.SourceError
|
|
33
|
|
-import GHC.Types.SrcLoc
|
|
34
|
|
-import GHC.Types.PkgQual
|
|
35
|
|
-import Data.List (partition)
|
|
36
|
|
-import GHC.Utils.TmpFs
|
|
|
31
|
+import GHC.Driver.Make
|
|
|
32
|
+import GHC.Driver.Monad
|
|
|
33
|
+import GHC.Driver.Phases
|
|
|
34
|
+import GHC.Driver.Pipeline
|
|
|
35
|
+import GHC.Driver.Pipeline.Monad
|
|
|
36
|
+import GHC.Driver.Session
|
|
37
|
37
|
|
|
|
38
|
+import GHC.Iface.Errors.Types
|
|
38
|
39
|
import GHC.Iface.Load (cannotFindModule)
|
|
39
|
40
|
|
|
|
41
|
+import GHC.SysTools qualified as SysTools
|
|
|
42
|
+import GHC.Types.PkgQual
|
|
|
43
|
+import GHC.Types.SourceError
|
|
|
44
|
+import GHC.Types.SrcLoc
|
|
|
45
|
+import GHC.Types.Unique.Set (UniqSet)
|
|
|
46
|
+import GHC.Types.Unique.Set qualified as UniqSet
|
|
|
47
|
+import GHC.Types.UnresolvedImport
|
|
|
48
|
+
|
|
|
49
|
+import GHC.Unit.Finder
|
|
|
50
|
+import GHC.Unit.Info
|
|
40
|
51
|
import GHC.Unit.Module
|
|
41
|
|
-import GHC.Unit.Module.ModSummary
|
|
42
|
52
|
import GHC.Unit.Module.Graph
|
|
43
|
|
-import GHC.Unit.Finder
|
|
|
53
|
+import GHC.Unit.Module.ModSummary
|
|
|
54
|
+import GHC.Unit.State (lookupUnitId)
|
|
44
|
55
|
|
|
45
|
|
-import GHC.Utils.Exception
|
|
46
|
56
|
import GHC.Utils.Error
|
|
|
57
|
+import GHC.Utils.Exception
|
|
|
58
|
+import GHC.Utils.Json
|
|
47
|
59
|
import GHC.Utils.Logger
|
|
|
60
|
+import GHC.Utils.Misc
|
|
|
61
|
+import GHC.Utils.Outputable
|
|
|
62
|
+import GHC.Utils.Panic
|
|
|
63
|
+import GHC.Utils.TmpFs
|
|
48
|
64
|
|
|
|
65
|
+import Control.Monad (when)
|
|
|
66
|
+import Data.Either
|
|
|
67
|
+import Data.Foldable (traverse_)
|
|
|
68
|
+import Data.IORef
|
|
|
69
|
+import Data.List (partition)
|
|
|
70
|
+import Data.Map.Strict qualified as Map
|
|
|
71
|
+import Data.Maybe (isJust, isNothing)
|
|
|
72
|
+import Data.Semigroup qualified as Semigroup
|
|
|
73
|
+import Data.Set qualified as Set
|
|
|
74
|
+import GHC.Generics (Generic, Generically (..))
|
|
49
|
75
|
import System.Directory
|
|
50
|
76
|
import System.FilePath
|
|
51
|
77
|
import System.IO
|
|
52
|
|
-import System.IO.Error ( isEOFError )
|
|
53
|
|
-import Control.Monad ( when, forM_ )
|
|
54
|
|
-import Data.Maybe ( isJust )
|
|
55
|
|
-import Data.IORef
|
|
56
|
|
-import qualified Data.Set as Set
|
|
57
|
|
-import GHC.Iface.Errors.Types
|
|
58
|
|
-import Data.Either
|
|
59
|
|
-import GHC.Data.Bag (listToBag)
|
|
|
78
|
+import System.IO.Error (isEOFError)
|
|
60
|
79
|
|
|
61
|
80
|
-----------------------------------------------------------------
|
|
62
|
81
|
--
|
| ... |
... |
@@ -98,27 +117,52 @@ doMkDependHS srcs = do |
|
98
|
117
|
|
|
99
|
118
|
doMkDependModuleGraph :: GhcMonad m => DynFlags -> ModuleGraph -> m ()
|
|
100
|
119
|
doMkDependModuleGraph dflags module_graph = do
|
|
|
120
|
+ hsc_env <- getSession
|
|
101
|
121
|
logger <- getLogger
|
|
102
|
|
- tmpfs <- hsc_tmpfs <$> getSession
|
|
103
|
|
- let excl_mods = depExcludeMods dflags
|
|
|
122
|
+ let
|
|
|
123
|
+ tmpfs = hsc_tmpfs hsc_env
|
|
|
124
|
+ excl_mods = depExcludeMods dflags
|
|
104
|
125
|
|
|
105
|
|
- files <- liftIO $ beginMkDependHS logger tmpfs dflags
|
|
106
|
|
- let sorted = GHC.topSortModuleGraph False module_graph Nothing
|
|
|
126
|
+ root <- liftIO getCurrentDirectory
|
|
|
127
|
+ let
|
|
|
128
|
+ dep_writer =
|
|
|
129
|
+ concat
|
|
|
130
|
+ [ [ SomeDependencyWriter $ initFileDepWriter logger root tmpfs dflags
|
|
|
131
|
+ ]
|
|
|
132
|
+ , [ SomeDependencyWriter $ initJsonDepWriter json_output dflags
|
|
|
133
|
+ | Just json_output <- [depJson dflags]
|
|
|
134
|
+ ]
|
|
|
135
|
+ ]
|
|
107
|
136
|
|
|
|
137
|
+
|
|
|
138
|
+ let sorted = GHC.topSortModuleGraph False module_graph Nothing
|
|
108
|
139
|
-- Print out the dependencies if wanted
|
|
109
|
140
|
liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted)
|
|
110
|
141
|
|
|
111
|
|
- -- Process them one by one, dumping results into makefile
|
|
112
|
|
- -- and complaining about cycles
|
|
113
|
|
- hsc_env <- getSession
|
|
114
|
|
- root <- liftIO getCurrentDirectory
|
|
115
|
|
- mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
|
|
116
|
|
-
|
|
117
|
|
- -- If -ddump-mod-cycles, show cycles in the module graph
|
|
118
|
|
- liftIO $ dumpModCycles logger module_graph
|
|
119
|
|
-
|
|
120
|
|
- -- Tidy up
|
|
121
|
|
- liftIO $ endMkDependHS logger files
|
|
|
142
|
+ liftIO $ bracket
|
|
|
143
|
+ (do
|
|
|
144
|
+ traverse
|
|
|
145
|
+ (\ (SomeDependencyWriter writer) -> do
|
|
|
146
|
+ backend <- dw_beginWriter writer
|
|
|
147
|
+ pure $ SomeActiveDependencyWriter (writer, backend)
|
|
|
148
|
+ )
|
|
|
149
|
+ dep_writer
|
|
|
150
|
+ )
|
|
|
151
|
+ -- Tidy up
|
|
|
152
|
+ (\ writers -> do
|
|
|
153
|
+ traverse_
|
|
|
154
|
+ (\ (SomeActiveDependencyWriter (writer, backend)) -> do
|
|
|
155
|
+ dw_endWriter writer backend
|
|
|
156
|
+ )
|
|
|
157
|
+ writers
|
|
|
158
|
+ )
|
|
|
159
|
+ ( \ writers -> do
|
|
|
160
|
+ -- Process them one by one, dumping results and complaining about cycles
|
|
|
161
|
+ mapM_ (processDeps dflags hsc_env (UniqSet.mkUniqSet excl_mods) writers) sorted
|
|
|
162
|
+
|
|
|
163
|
+ -- If -ddump-mod-cycles, show cycles in the module graph
|
|
|
164
|
+ liftIO $ dumpModCycles logger module_graph
|
|
|
165
|
+ )
|
|
122
|
166
|
|
|
123
|
167
|
-- Unconditional exiting is a bad idea. If an error occurs we'll get an
|
|
124
|
168
|
--exception; if that is not caught it's fine, but at least we have a
|
| ... |
... |
@@ -127,6 +171,196 @@ doMkDependModuleGraph dflags module_graph = do |
|
127
|
171
|
|
|
128
|
172
|
--`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
|
|
129
|
173
|
|
|
|
174
|
+--------------------------------------------------------------------------------
|
|
|
175
|
+-- Types abstracting over the output
|
|
|
176
|
+--------------------------------------------------------------------------------
|
|
|
177
|
+
|
|
|
178
|
+data DepNode =
|
|
|
179
|
+ DepNode
|
|
|
180
|
+ { dn_mod :: Module
|
|
|
181
|
+ , dn_src :: FilePath
|
|
|
182
|
+ , dn_obj :: FilePath
|
|
|
183
|
+ , dn_hi :: FilePath
|
|
|
184
|
+ , dn_boot :: IsBootInterface
|
|
|
185
|
+ , dn_preprocessing :: PreprocessingNode
|
|
|
186
|
+ }
|
|
|
187
|
+
|
|
|
188
|
+data PreprocessingNode = PreprocessingNode
|
|
|
189
|
+ { pn_preprocessor :: Maybe String
|
|
|
190
|
+ , pn_options :: [String]
|
|
|
191
|
+ }
|
|
|
192
|
+
|
|
|
193
|
+data Dep
|
|
|
194
|
+ = DepHi
|
|
|
195
|
+ { dep_mod :: Module
|
|
|
196
|
+ , dep_path :: FilePath
|
|
|
197
|
+ , dep_unit :: Maybe UnitInfo
|
|
|
198
|
+ , dep_local :: Bool
|
|
|
199
|
+ , dep_boot :: IsBootInterface
|
|
|
200
|
+ }
|
|
|
201
|
+ | DepCpp
|
|
|
202
|
+ { dep_path :: FilePath
|
|
|
203
|
+ }
|
|
|
204
|
+
|
|
|
205
|
+data SomeDependencyWriter = forall backend . SomeDependencyWriter (DependencyWriter backend)
|
|
|
206
|
+
|
|
|
207
|
+data SomeActiveDependencyWriter = forall backend . SomeActiveDependencyWriter (DependencyWriter backend, backend)
|
|
|
208
|
+
|
|
|
209
|
+data DependencyWriter backend = DependencyWriter
|
|
|
210
|
+ { dw_beginWriter :: IO backend
|
|
|
211
|
+ , dw_writeDependency :: backend -> DepNode -> [Dep] -> IO ()
|
|
|
212
|
+ , dw_endWriter :: backend -> IO ()
|
|
|
213
|
+ }
|
|
|
214
|
+
|
|
|
215
|
+-----------------------------------------------------------------
|
|
|
216
|
+--
|
|
|
217
|
+-- processDeps
|
|
|
218
|
+--
|
|
|
219
|
+-----------------------------------------------------------------
|
|
|
220
|
+
|
|
|
221
|
+processDeps :: DynFlags
|
|
|
222
|
+ -> HscEnv
|
|
|
223
|
+ -> UniqSet ModuleName -- ^ Excludes
|
|
|
224
|
+ -> [SomeActiveDependencyWriter]
|
|
|
225
|
+ -> SCC ModuleGraphNode
|
|
|
226
|
+ -> IO ()
|
|
|
227
|
+-- Write suitable dependencies to handle
|
|
|
228
|
+-- Always:
|
|
|
229
|
+-- this.o : this.hs
|
|
|
230
|
+--
|
|
|
231
|
+-- If the dependency is on something other than a .hi file:
|
|
|
232
|
+-- this.o this.p_o ... : dep
|
|
|
233
|
+-- otherwise
|
|
|
234
|
+-- this.o ... : dep.hi
|
|
|
235
|
+-- this.p_o ... : dep.p_hi
|
|
|
236
|
+-- ...
|
|
|
237
|
+-- (where .o is $osuf, and the other suffixes come from
|
|
|
238
|
+-- the cmdline -s options).
|
|
|
239
|
+--
|
|
|
240
|
+-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
|
|
|
241
|
+
|
|
|
242
|
+processDeps _ hsc_env _ _ (CyclicSCC nodes)
|
|
|
243
|
+ = -- There shouldn't be any cycles; report them
|
|
|
244
|
+ throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $ cyclicModuleErr nodes
|
|
|
245
|
+
|
|
|
246
|
+processDeps _ hsc_env _ _ (AcyclicSCC (InstantiationNode _uid node))
|
|
|
247
|
+ = -- There shouldn't be any backpack instantiations; report them as well
|
|
|
248
|
+ throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $
|
|
|
249
|
+ mkPlainErrorMsgEnvelope noSrcSpan $
|
|
|
250
|
+ GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node
|
|
|
251
|
+
|
|
|
252
|
+processDeps _dflags _ _ _ (AcyclicSCC (LinkNode {})) = return ()
|
|
|
253
|
+processDeps _dflags _ _ _ (AcyclicSCC (UnitNode {})) = return ()
|
|
|
254
|
+processDeps _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {})))
|
|
|
255
|
+ -- No dependencies needed for fixed modules (already compiled)
|
|
|
256
|
+ = return ()
|
|
|
257
|
+
|
|
|
258
|
+processDeps dflags hsc_env excl_mods backends (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do
|
|
|
259
|
+ pp <- preprocessor
|
|
|
260
|
+ let
|
|
|
261
|
+ dep_node = mkDepNode pp
|
|
|
262
|
+ find_deps imps = do
|
|
|
263
|
+ cpp_deps <- find_cpp_deps
|
|
|
264
|
+ import_deps <- find_import_deps imps
|
|
|
265
|
+ pure $ map Right cpp_deps ++ import_deps
|
|
|
266
|
+ (missing_dep_errs, deps) <- partitionEithers <$> find_deps (ms_imps node)
|
|
|
267
|
+
|
|
|
268
|
+ if null missing_dep_errs
|
|
|
269
|
+ then do
|
|
|
270
|
+ traverse_ (\ (SomeActiveDependencyWriter (writer, backend)) -> dw_writeDependency writer backend dep_node deps) backends
|
|
|
271
|
+ else do
|
|
|
272
|
+ let sec = initSourceErrorContext (hsc_dflags hsc_env)
|
|
|
273
|
+ throwErrors sec (mkMessages (listToBag missing_dep_errs))
|
|
|
274
|
+ where
|
|
|
275
|
+ src_file = msHsFilePath node
|
|
|
276
|
+ mkDepNode preproc =
|
|
|
277
|
+ DepNode {
|
|
|
278
|
+ dn_mod = ms_mod node,
|
|
|
279
|
+ dn_src = src_file,
|
|
|
280
|
+ dn_obj = msObjFilePath node,
|
|
|
281
|
+ dn_hi = msHiFilePath node,
|
|
|
282
|
+ dn_boot = isBootSummary node,
|
|
|
283
|
+ dn_preprocessing = preproc
|
|
|
284
|
+ }
|
|
|
285
|
+
|
|
|
286
|
+ preprocessor :: IO PreprocessingNode
|
|
|
287
|
+ preprocessor
|
|
|
288
|
+ | Just src <- ml_hs_file (ms_location node)
|
|
|
289
|
+ = runPipeline (hsc_hooks hsc_env) $ do
|
|
|
290
|
+ let (_, suffix) = splitExtension src
|
|
|
291
|
+ lit | Unlit _ <- startPhase suffix = True
|
|
|
292
|
+ | otherwise = False
|
|
|
293
|
+ pipe_env = mkPipeEnv StopPreprocess src Nothing NoOutputFile
|
|
|
294
|
+ unlit_fn <- if lit then use (T_Unlit pipe_env hsc_env src) else pure src
|
|
|
295
|
+ (dflags1, opts, _, _) <- use (T_FileArgs (hsc_logger hsc_env) (hsc_dflags hsc_env) unlit_fn)
|
|
|
296
|
+ let pp = pgm_F dflags1
|
|
|
297
|
+ pure PreprocessingNode
|
|
|
298
|
+ { pn_preprocessor = if null pp then global_preprocessor else Just pp
|
|
|
299
|
+ , pn_options = opts
|
|
|
300
|
+ }
|
|
|
301
|
+ | otherwise
|
|
|
302
|
+ = pure PreprocessingNode
|
|
|
303
|
+ { pn_preprocessor = global_preprocessor
|
|
|
304
|
+ , pn_options = []
|
|
|
305
|
+ }
|
|
|
306
|
+
|
|
|
307
|
+ global_preprocessor :: Maybe String
|
|
|
308
|
+ global_preprocessor
|
|
|
309
|
+ | let pp = pgm_F dflags
|
|
|
310
|
+ , not (null pp)
|
|
|
311
|
+ = Just pp
|
|
|
312
|
+ | otherwise
|
|
|
313
|
+ = Nothing
|
|
|
314
|
+
|
|
|
315
|
+ -- Emit a dependency for each CPP import
|
|
|
316
|
+ -- CPP deps are discovered in the module parsing phase by parsing
|
|
|
317
|
+ -- comment lines left by the preprocessor.
|
|
|
318
|
+ -- Note that GHC.parseModule may throw an exception if the module
|
|
|
319
|
+ -- fails to parse, which may not be desirable (see #16616).
|
|
|
320
|
+ find_cpp_deps :: IO [Dep]
|
|
|
321
|
+ find_cpp_deps = do
|
|
|
322
|
+ session <- Session <$> newIORef hsc_env
|
|
|
323
|
+ parsedMod <- reflectGhc (GHC.parseModule node) session
|
|
|
324
|
+ pure (DepCpp <$> GHC.pm_extra_src_files parsedMod)
|
|
|
325
|
+
|
|
|
326
|
+ -- Emit a dependency for each import
|
|
|
327
|
+ find_import_deps :: [UnresolvedImport PkgQual] -> IO [Either (MsgEnvelope GhcMessage) Dep]
|
|
|
328
|
+ find_import_deps idecls =
|
|
|
329
|
+ sequence
|
|
|
330
|
+ [ findDependency hsc_env decl
|
|
|
331
|
+ | decl <- idecls
|
|
|
332
|
+ , let L _loc mod = ui_mod_name decl
|
|
|
333
|
+ , not $ mod `UniqSet.elementOfUniqSet` excl_mods
|
|
|
334
|
+ ]
|
|
|
335
|
+
|
|
|
336
|
+findDependency :: HscEnv
|
|
|
337
|
+ -> UnresolvedImport PkgQual -- The import to find
|
|
|
338
|
+ -> IO (Either (MsgEnvelope GhcMessage) Dep) -- Interface file
|
|
|
339
|
+findDependency hsc_env imp = do
|
|
|
340
|
+ -- Find the module; this will be fast because
|
|
|
341
|
+ -- we've done it once during downsweep.
|
|
|
342
|
+ r <- resolveImport hsc_env imp
|
|
|
343
|
+ case r of
|
|
|
344
|
+ Found loc dep_mod ->
|
|
|
345
|
+ pure $ Right
|
|
|
346
|
+ DepHi
|
|
|
347
|
+ { dep_mod = dep_mod
|
|
|
348
|
+ , dep_path = ml_hi_file loc
|
|
|
349
|
+ , dep_unit = lookupUnitId (hsc_units hsc_env) (moduleUnitId dep_mod)
|
|
|
350
|
+ , dep_local = isJust (ml_hs_file loc)
|
|
|
351
|
+ , dep_boot = is_boot
|
|
|
352
|
+ }
|
|
|
353
|
+
|
|
|
354
|
+ fail ->
|
|
|
355
|
+ return $
|
|
|
356
|
+ Left $
|
|
|
357
|
+ mkPlainErrorMsgEnvelope srcloc $
|
|
|
358
|
+ GhcDriverMessage $ DriverInterfaceError $
|
|
|
359
|
+ (Can'tFindInterface (cannotFindModule hsc_env mod_name fail) (LookingForModule mod_name is_boot))
|
|
|
360
|
+ where
|
|
|
361
|
+ L srcloc mod_name = ui_mod_name imp
|
|
|
362
|
+ is_boot = ui_boot imp
|
|
|
363
|
+
|
|
130
|
364
|
-----------------------------------------------------------------
|
|
131
|
365
|
--
|
|
132
|
366
|
-- beginMkDependHs
|
| ... |
... |
@@ -136,6 +370,14 @@ doMkDependModuleGraph dflags module_graph = do |
|
136
|
370
|
--
|
|
137
|
371
|
-----------------------------------------------------------------
|
|
138
|
372
|
|
|
|
373
|
+initFileDepWriter :: Logger -> FilePath -> TmpFs -> DynFlags -> DependencyWriter MkDepFiles
|
|
|
374
|
+initFileDepWriter logger root tmpfs dflags = DependencyWriter
|
|
|
375
|
+ { dw_beginWriter = beginMkDependHS logger tmpfs dflags
|
|
|
376
|
+ , dw_writeDependency = \ backend node deps -> do
|
|
|
377
|
+ writeDependencies (depIncludePkgDeps dflags) root (mkd_tmp_hdl backend) (depSuffixes dflags) node deps
|
|
|
378
|
+ , dw_endWriter = endMkDependHS logger
|
|
|
379
|
+ }
|
|
|
380
|
+
|
|
139
|
381
|
data MkDepFiles
|
|
140
|
382
|
= MkDep { mkd_make_file :: FilePath, -- Name of the makefile
|
|
141
|
383
|
mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile
|
| ... |
... |
@@ -188,138 +430,54 @@ beginMkDependHS logger tmpfs dflags = do |
|
188
|
430
|
return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
|
|
189
|
431
|
mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl})
|
|
190
|
432
|
|
|
|
433
|
+writeDependencies ::
|
|
|
434
|
+ Bool ->
|
|
|
435
|
+ FilePath ->
|
|
|
436
|
+ Handle ->
|
|
|
437
|
+ [FilePath] ->
|
|
|
438
|
+ DepNode ->
|
|
|
439
|
+ [Dep] ->
|
|
|
440
|
+ IO ()
|
|
|
441
|
+writeDependencies include_pkgs root hdl suffixes node deps =
|
|
|
442
|
+ traverse_ write tasks
|
|
|
443
|
+ where
|
|
|
444
|
+ tasks = source_dep : boot_dep ++ concatMap import_dep deps
|
|
|
445
|
+
|
|
|
446
|
+ -- Emit std dependency of the object(s) on the source file
|
|
|
447
|
+ -- Something like A.o : A.hs
|
|
|
448
|
+ source_dep = (obj_files, dn_src)
|
|
|
449
|
+
|
|
|
450
|
+ -- add dependency between objects and their corresponding .hi-boot
|
|
|
451
|
+ -- files if the module has a corresponding .hs-boot file (#14482)
|
|
|
452
|
+ boot_dep
|
|
|
453
|
+ | IsBoot <- dn_boot
|
|
|
454
|
+ = [([obj], hi) | (obj, hi) <- zip (suffixed (viaOsPath removeBootSuffix dn_obj)) (suffixed dn_hi)]
|
|
|
455
|
+ | otherwise
|
|
|
456
|
+ = []
|
|
|
457
|
+
|
|
|
458
|
+ -- Add one dependency for each suffix;
|
|
|
459
|
+ -- e.g. A.o : B.hi
|
|
|
460
|
+ -- A.x_o : B.x_hi
|
|
|
461
|
+ import_dep = \case
|
|
|
462
|
+ DepHi {dep_path, dep_boot, dep_unit}
|
|
|
463
|
+ | isNothing dep_unit || include_pkgs
|
|
|
464
|
+ , let path = if dep_boot == IsBoot then viaOsPath addBootSuffix dep_path else dep_path
|
|
|
465
|
+ -> [([obj], hi) | (obj, hi) <- zip obj_files (suffixed path)]
|
|
191
|
466
|
|
|
192
|
|
------------------------------------------------------------------
|
|
193
|
|
---
|
|
194
|
|
--- processDeps
|
|
195
|
|
---
|
|
196
|
|
------------------------------------------------------------------
|
|
197
|
|
-
|
|
198
|
|
-processDeps :: DynFlags
|
|
199
|
|
- -> HscEnv
|
|
200
|
|
- -> [ModuleName]
|
|
201
|
|
- -> FilePath
|
|
202
|
|
- -> Handle -- Write dependencies to here
|
|
203
|
|
- -> SCC ModuleGraphNode
|
|
204
|
|
- -> IO ()
|
|
205
|
|
--- Write suitable dependencies to handle
|
|
206
|
|
--- Always:
|
|
207
|
|
--- this.o : this.hs
|
|
208
|
|
---
|
|
209
|
|
--- If the dependency is on something other than a .hi file:
|
|
210
|
|
--- this.o this.p_o ... : dep
|
|
211
|
|
--- otherwise
|
|
212
|
|
--- this.o ... : dep.hi
|
|
213
|
|
--- this.p_o ... : dep.p_hi
|
|
214
|
|
--- ...
|
|
215
|
|
--- (where .o is $osuf, and the other suffixes come from
|
|
216
|
|
--- the cmdline -s options).
|
|
217
|
|
---
|
|
218
|
|
--- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
|
|
219
|
|
-
|
|
220
|
|
-processDeps _ hsc_env _ _ _ (CyclicSCC nodes)
|
|
221
|
|
- = -- There shouldn't be any cycles; report them
|
|
222
|
|
- throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $ cyclicModuleErr nodes
|
|
223
|
|
-
|
|
224
|
|
-processDeps _ hsc_env _ _ _ (AcyclicSCC (InstantiationNode _uid node))
|
|
225
|
|
- = -- There shouldn't be any backpack instantiations; report them as well
|
|
226
|
|
- throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $
|
|
227
|
|
- mkPlainErrorMsgEnvelope noSrcSpan $
|
|
228
|
|
- GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node
|
|
229
|
|
-
|
|
230
|
|
-processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()
|
|
231
|
|
-processDeps _dflags _ _ _ _ (AcyclicSCC (UnitNode {})) = return ()
|
|
232
|
|
-processDeps _ _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {})))
|
|
233
|
|
- -- No dependencies needed for fixed modules (already compiled)
|
|
234
|
|
- = return ()
|
|
235
|
|
-processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node)))
|
|
236
|
|
- = do { let extra_suffixes = depSuffixes dflags
|
|
237
|
|
- include_pkg_deps = depIncludePkgDeps dflags
|
|
238
|
|
- src_file = msHsFilePath node
|
|
239
|
|
- obj_file = msObjFilePath node
|
|
240
|
|
- obj_files = insertSuffixes obj_file extra_suffixes
|
|
241
|
|
-
|
|
242
|
|
-
|
|
243
|
|
-
|
|
244
|
|
- -- Emit std dependency of the object(s) on the source file
|
|
245
|
|
- -- Something like A.o : A.hs
|
|
246
|
|
- ; writeDependency root hdl obj_files src_file
|
|
247
|
|
-
|
|
248
|
|
- -- add dependency between objects and their corresponding .hi-boot
|
|
249
|
|
- -- files if the module has a corresponding .hs-boot file (#14482)
|
|
250
|
|
- ; when (isBootSummary node == IsBoot) $ do
|
|
251
|
|
- let hi_boot = msHiFilePath node
|
|
252
|
|
- let obj = unsafeDecodeUtf $ removeBootSuffix (msObjFileOsPath node)
|
|
253
|
|
- forM_ extra_suffixes $ \suff -> do
|
|
254
|
|
- let way_obj = insertSuffixes obj [suff]
|
|
255
|
|
- let way_hi_boot = insertSuffixes hi_boot [suff]
|
|
256
|
|
- mapM_ (writeDependency root hdl way_obj) way_hi_boot
|
|
257
|
|
-
|
|
258
|
|
- -- Emit a dependency for each CPP import
|
|
259
|
|
- ; when (depIncludeCppDeps dflags) $ do
|
|
260
|
|
- -- CPP deps are discovered in the module parsing phase by parsing
|
|
261
|
|
- -- comment lines left by the preprocessor.
|
|
262
|
|
- -- Note that GHC.parseModule may throw an exception if the module
|
|
263
|
|
- -- fails to parse, which may not be desirable (see #16616).
|
|
264
|
|
- { session <- Session <$> newIORef hsc_env
|
|
265
|
|
- ; parsedMod <- reflectGhc (GHC.parseModule node) session
|
|
266
|
|
- ; mapM_ (writeDependency root hdl obj_files)
|
|
267
|
|
- (GHC.pm_extra_src_files parsedMod)
|
|
268
|
|
- }
|
|
269
|
|
-
|
|
270
|
|
- -- Emit a dependency for each import
|
|
|
467
|
+ | otherwise
|
|
|
468
|
+ -> []
|
|
271
|
469
|
|
|
272
|
|
- ; let find_deps imps = sequence
|
|
273
|
|
- [ findDependency hsc_env imp include_pkg_deps
|
|
274
|
|
- | imp <- imps
|
|
275
|
|
- , unLoc (ui_mod_name imp) `notElem` excl_mods
|
|
276
|
|
- ]
|
|
|
470
|
+ DepCpp {dep_path} -> [(obj_files, dep_path)]
|
|
277
|
471
|
|
|
278
|
|
- do_imp hi_file = do
|
|
279
|
|
- let hi_files = insertSuffixes hi_file extra_suffixes
|
|
280
|
|
- write_dep (obj,hi) = writeDependency root hdl [obj] hi
|
|
|
472
|
+ write (from, to) = writeDependency root hdl from to
|
|
281
|
473
|
|
|
282
|
|
- -- Add one dependency for each suffix;
|
|
283
|
|
- -- e.g. A.o : B.hi
|
|
284
|
|
- -- A.x_o : B.x_hi
|
|
285
|
|
- mapM_ write_dep (obj_files `zip` hi_files)
|
|
|
474
|
+ obj_files = suffixed dn_obj
|
|
286
|
475
|
|
|
287
|
|
- ; (missing_dep_errs, deps) <- partitionEithers <$> find_deps (ms_imps node)
|
|
|
476
|
+ suffixed f = insertSuffixes f suffixes
|
|
288
|
477
|
|
|
289
|
|
- ; if null missing_dep_errs
|
|
290
|
|
- then mapM_ (mapM_ do_imp) deps
|
|
291
|
|
- else do
|
|
292
|
|
- let sec = initSourceErrorContext (hsc_dflags hsc_env)
|
|
293
|
|
- throwErrors sec (mkMessages (listToBag missing_dep_errs))
|
|
294
|
|
- }
|
|
|
478
|
+ DepNode {dn_src, dn_obj, dn_hi, dn_boot} = node
|
|
295
|
479
|
|
|
296
|
|
-findDependency :: HscEnv
|
|
297
|
|
- -> UnresolvedImport PkgQual -- The import to find
|
|
298
|
|
- -> Bool -- Record dependency on package modules
|
|
299
|
|
- -> IO (Either (MsgEnvelope GhcMessage) (Maybe FilePath)) -- Interface file
|
|
300
|
|
-findDependency hsc_env imp include_pkg_deps = do
|
|
301
|
|
- -- Find the module; this will be fast because
|
|
302
|
|
- -- we've done it once during downsweep.
|
|
303
|
|
- r <- resolveImport hsc_env imp
|
|
304
|
|
- case r of
|
|
305
|
|
- Found loc _
|
|
306
|
|
- -- Home package: just depend on the .hi or hi-boot file
|
|
307
|
|
- | isJust (ml_hs_file loc) || include_pkg_deps
|
|
308
|
|
- -> return (Right (Just (ml_hi_file loc)))
|
|
309
|
|
-
|
|
310
|
|
- -- Not in this package: we don't need a dependency
|
|
311
|
|
- | otherwise
|
|
312
|
|
- -> return (Right Nothing)
|
|
313
|
|
-
|
|
314
|
|
- fail ->
|
|
315
|
|
- return $
|
|
316
|
|
- Left $
|
|
317
|
|
- mkPlainErrorMsgEnvelope srcloc $
|
|
318
|
|
- GhcDriverMessage $ DriverInterfaceError $
|
|
319
|
|
- (Can'tFindInterface (cannotFindModule hsc_env mod_name fail) (LookingForModule mod_name is_boot))
|
|
320
|
|
- where
|
|
321
|
|
- L srcloc mod_name = ui_mod_name imp
|
|
322
|
|
- is_boot = ui_boot imp
|
|
|
480
|
+ viaOsPath f a = unsafeDecodeUtf (f (unsafeEncodeUtf a))
|
|
323
|
481
|
|
|
324
|
482
|
-----------------------------
|
|
325
|
483
|
writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
|
| ... |
... |
@@ -328,7 +486,7 @@ writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () |
|
328
|
486
|
writeDependency root hdl targets dep
|
|
329
|
487
|
= do let -- We need to avoid making deps on
|
|
330
|
488
|
-- c:/foo/...
|
|
331
|
|
- -- on Windows as make gets confused by the :
|
|
|
489
|
+ -- on cygwin as make gets confused by the :
|
|
332
|
490
|
-- Making relative deps avoids some instances of this.
|
|
333
|
491
|
dep' = makeRelative root dep
|
|
334
|
492
|
forOutput = escapeSpaces . reslash Forwards . normalise
|
| ... |
... |
@@ -352,11 +510,8 @@ insertSuffixes file_name extras |
|
352
|
510
|
|
|
353
|
511
|
|
|
354
|
512
|
-----------------------------------------------------------------
|
|
355
|
|
---
|
|
356
|
|
--- endMkDependHs
|
|
357
|
|
--- Complete the makefile, close the tmp file etc
|
|
358
|
|
---
|
|
359
|
|
------------------------------------------------------------------
|
|
|
513
|
+-- endMkDependHs
|
|
|
514
|
+-- Complete the makefile, close the tmp file etc
|
|
360
|
515
|
|
|
361
|
516
|
endMkDependHS :: Logger -> MkDepFiles -> IO ()
|
|
362
|
517
|
|
| ... |
... |
@@ -385,6 +540,183 @@ endMkDependHS logger |
|
385
|
540
|
showPass logger "Installing new makefile"
|
|
386
|
541
|
SysTools.copyFile tmp_file makefile
|
|
387
|
542
|
|
|
|
543
|
+-----------------------------------------------------------------
|
|
|
544
|
+--
|
|
|
545
|
+-- JSON MkDepends output
|
|
|
546
|
+--
|
|
|
547
|
+-----------------------------------------------------------------
|
|
|
548
|
+
|
|
|
549
|
+initJsonDepWriter :: FilePath -> DynFlags -> DependencyWriter (JsonOutput DepJson)
|
|
|
550
|
+initJsonDepWriter output dflags = DependencyWriter
|
|
|
551
|
+ { dw_beginWriter = do
|
|
|
552
|
+ mkJsonOutput output initDepJson
|
|
|
553
|
+ , dw_writeDependency = \ backend node deps -> do
|
|
|
554
|
+ updateJson backend (updateDepJson (depIncludePkgDeps dflags) node deps)
|
|
|
555
|
+ , dw_endWriter =
|
|
|
556
|
+ writeJsonOutput
|
|
|
557
|
+ }
|
|
|
558
|
+
|
|
|
559
|
+--------------------------------------------------------------------------------
|
|
|
560
|
+-- Output interface for json dumps
|
|
|
561
|
+
|
|
|
562
|
+-- | Resources for a json dump option, used in "GHC.Driver.MakeFile".
|
|
|
563
|
+-- The flag @-dep-json@ add an additional output target for dependency
|
|
|
564
|
+-- diagnostics.
|
|
|
565
|
+data JsonOutput a =
|
|
|
566
|
+ JsonOutput {
|
|
|
567
|
+ -- | This ref is updated in @processDeps@ incrementally, using a
|
|
|
568
|
+ -- flag-specific type.
|
|
|
569
|
+ json_ref :: IORef a,
|
|
|
570
|
+
|
|
|
571
|
+ -- | The output file path specified as argument to the flag.
|
|
|
572
|
+ json_path :: FilePath
|
|
|
573
|
+ }
|
|
|
574
|
+
|
|
|
575
|
+-- | TODO: @fendor
|
|
|
576
|
+mkJsonOutput ::
|
|
|
577
|
+ FilePath ->
|
|
|
578
|
+ IO (IORef a) ->
|
|
|
579
|
+ IO (JsonOutput a)
|
|
|
580
|
+mkJsonOutput json_path mk_ref = do
|
|
|
581
|
+ json_ref <- mk_ref
|
|
|
582
|
+ pure JsonOutput {json_ref, json_path}
|
|
|
583
|
+
|
|
|
584
|
+-- | Update the dump data in 'json_ref' if the output target is present.
|
|
|
585
|
+updateJson :: JsonOutput a -> (a -> a) -> IO ()
|
|
|
586
|
+updateJson JsonOutput {json_ref} f = modifyIORef' json_ref f
|
|
|
587
|
+
|
|
|
588
|
+-- | Write a json object to the flag-dependent file if the output target is
|
|
|
589
|
+-- present.
|
|
|
590
|
+writeJsonOutput ::
|
|
|
591
|
+ ToJson a =>
|
|
|
592
|
+ JsonOutput a ->
|
|
|
593
|
+ IO ()
|
|
|
594
|
+writeJsonOutput JsonOutput {json_ref, json_path} = do
|
|
|
595
|
+ payload <- readIORef json_ref
|
|
|
596
|
+ writeJsonFile payload json_path
|
|
|
597
|
+
|
|
|
598
|
+--------------------------------------------------------------------------------
|
|
|
599
|
+-- Output helpers
|
|
|
600
|
+
|
|
|
601
|
+writeJsonFile :: ToJson a => a -> FilePath -> IO ()
|
|
|
602
|
+writeJsonFile doc p = do
|
|
|
603
|
+ withAtomicRename p
|
|
|
604
|
+ $ \tmp -> writeFile tmp $ showSDocUnsafe $ renderJSON $ json doc
|
|
|
605
|
+
|
|
|
606
|
+--------------------------------------------------------------------------------
|
|
|
607
|
+-- Payload for -dep-json
|
|
|
608
|
+
|
|
|
609
|
+newtype PackageDeps
|
|
|
610
|
+ = PackageDeps (Map.Map (String, UnitId, DPackageId) (Set.Set ModuleName))
|
|
|
611
|
+ deriving newtype (Monoid)
|
|
|
612
|
+
|
|
|
613
|
+newtype DPackageId = DPackageId PackageId
|
|
|
614
|
+ deriving newtype (Eq)
|
|
|
615
|
+
|
|
|
616
|
+instance Ord DPackageId where
|
|
|
617
|
+ DPackageId (PackageId d1) `compare` DPackageId (PackageId d2) = d1 `lexicalCompareFS` d2
|
|
|
618
|
+
|
|
|
619
|
+instance Semigroup PackageDeps where
|
|
|
620
|
+ PackageDeps l <> PackageDeps r = PackageDeps (Map.unionWith (Semigroup.<>) l r)
|
|
|
621
|
+
|
|
|
622
|
+data Deps
|
|
|
623
|
+ = Deps
|
|
|
624
|
+ { sources :: Set.Set FilePath
|
|
|
625
|
+ , modules :: (Set.Set ModuleName, Set.Set ModuleName)
|
|
|
626
|
+ , packages :: PackageDeps
|
|
|
627
|
+ , cpp :: Set.Set FilePath
|
|
|
628
|
+ , options :: [String]
|
|
|
629
|
+ , preprocessor :: Maybe FilePath
|
|
|
630
|
+ }
|
|
|
631
|
+ deriving stock (Generic)
|
|
|
632
|
+ deriving (Semigroup, Monoid) via (Generically Deps)
|
|
|
633
|
+
|
|
|
634
|
+newtype DepJson = DepJson (Map.Map ModuleName Deps)
|
|
|
635
|
+
|
|
|
636
|
+instance ToJson DepJson where
|
|
|
637
|
+ json (DepJson m) =
|
|
|
638
|
+ JSObject [
|
|
|
639
|
+ (moduleNameString target, JSObject [
|
|
|
640
|
+ ("sources", array sources normalise),
|
|
|
641
|
+ ("modules", array (fst modules) moduleNameString),
|
|
|
642
|
+ ("modules-boot", array (snd modules) moduleNameString),
|
|
|
643
|
+ ("packages",
|
|
|
644
|
+ JSArray
|
|
|
645
|
+ [ package name unit_id package_id mods
|
|
|
646
|
+ | ((name, unit_id, dpkd_id), mods) <- Map.toList packages
|
|
|
647
|
+ , let DPackageId package_id = dpkd_id
|
|
|
648
|
+ ]
|
|
|
649
|
+ ),
|
|
|
650
|
+ ("cpp", array cpp id),
|
|
|
651
|
+ ("options", JSArray $ map JSString options),
|
|
|
652
|
+ ("preprocessor", maybe JSNull JSString preprocessor)
|
|
|
653
|
+ ])
|
|
|
654
|
+ | (target, Deps {packages = PackageDeps packages, ..}) <- Map.toList m
|
|
|
655
|
+ ]
|
|
|
656
|
+ where
|
|
|
657
|
+ package name unit_id (PackageId package_id) mods =
|
|
|
658
|
+ JSObject [
|
|
|
659
|
+ ("id", JSString (unitIdString unit_id)),
|
|
|
660
|
+ ("name", JSString name),
|
|
|
661
|
+ ("package-id", JSString (unpackFS package_id)),
|
|
|
662
|
+ ("modules", array mods moduleNameString)
|
|
|
663
|
+ ]
|
|
|
664
|
+
|
|
|
665
|
+ array values render = JSArray (fmap (JSString . render) (Set.toList values))
|
|
|
666
|
+
|
|
|
667
|
+initDepJson :: IO (IORef DepJson)
|
|
|
668
|
+initDepJson = newIORef $ DepJson Map.empty
|
|
|
669
|
+
|
|
|
670
|
+insertDepJson :: [ModuleName] -> Deps -> DepJson -> DepJson
|
|
|
671
|
+insertDepJson targets dep (DepJson m0) =
|
|
|
672
|
+ DepJson
|
|
|
673
|
+ $ foldl'
|
|
|
674
|
+ ( \acc target ->
|
|
|
675
|
+ Map.insertWith
|
|
|
676
|
+ (Semigroup.<>)
|
|
|
677
|
+ target
|
|
|
678
|
+ dep
|
|
|
679
|
+ acc
|
|
|
680
|
+ )
|
|
|
681
|
+ m0
|
|
|
682
|
+ targets
|
|
|
683
|
+
|
|
|
684
|
+updateDepJson :: Bool -> DepNode -> [Dep] -> DepJson -> DepJson
|
|
|
685
|
+updateDepJson include_pkgs DepNode {..} deps =
|
|
|
686
|
+ insertDepJson [moduleName dn_mod] payload
|
|
|
687
|
+ where
|
|
|
688
|
+ payload = node_data Semigroup.<> foldMap dep deps
|
|
|
689
|
+
|
|
|
690
|
+ node_data =
|
|
|
691
|
+ mempty {
|
|
|
692
|
+ sources = Set.singleton dn_src,
|
|
|
693
|
+ preprocessor = pn_preprocessor dn_preprocessing,
|
|
|
694
|
+ options = pn_options dn_preprocessing
|
|
|
695
|
+ }
|
|
|
696
|
+
|
|
|
697
|
+ dep = \case
|
|
|
698
|
+ DepHi {dep_mod, dep_local, dep_unit, dep_boot}
|
|
|
699
|
+ | dep_local
|
|
|
700
|
+ , let set = Set.singleton $ moduleName dep_mod
|
|
|
701
|
+ value | IsBoot <- dep_boot = (Set.empty, set)
|
|
|
702
|
+ | otherwise = (set, Set.empty)
|
|
|
703
|
+ -> mempty {modules = value}
|
|
|
704
|
+
|
|
|
705
|
+ | include_pkgs
|
|
|
706
|
+ , Just unit <- dep_unit
|
|
|
707
|
+ , let PackageName nameFS = unitPackageName unit
|
|
|
708
|
+ name = unpackFS nameFS
|
|
|
709
|
+ withLibName (PackageName c) = name ++ ":" ++ unpackFS c
|
|
|
710
|
+ lname = maybe name withLibName (unitComponentName unit)
|
|
|
711
|
+ key = (lname, unitId unit, DPackageId $ unitPackageId unit)
|
|
|
712
|
+ -> mempty {packages = PackageDeps (Map.singleton key (Set.singleton $ moduleName dep_mod))}
|
|
|
713
|
+
|
|
|
714
|
+ | otherwise
|
|
|
715
|
+ -> mempty
|
|
|
716
|
+
|
|
|
717
|
+ DepCpp {dep_path} ->
|
|
|
718
|
+ mempty {cpp = Set.singleton dep_path}
|
|
|
719
|
+
|
|
388
|
720
|
|
|
389
|
721
|
-----------------------------------------------------------------
|
|
390
|
722
|
-- Module cycles
|