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
|
-----------------------------------------------------------------------------
--
-- Makefile Dependency Generation
--
-- (c) The University of Glasgow 2005
--
-----------------------------------------------------------------------------
module GHC.Driver.MakeFile
( doMkDependHS
)
where
import GHC.Prelude
import qualified GHC
import GHC.Driver.Config.Finder
import GHC.Driver.Monad
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Utils.Misc
import GHC.Driver.Env
import GHC.Driver.Errors.Types
import qualified GHC.SysTools as SysTools
import GHC.Data.Graph.Directed ( SCC(..) )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.PkgQual
import Data.List (partition)
import GHC.Utils.TmpFs
import GHC.Iface.Load (cannotFindModule)
import GHC.Unit.Env
import GHC.Unit.Module
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Graph
import GHC.Unit.Finder
import GHC.Utils.Exception
import GHC.Utils.Error
import GHC.Utils.Logger
import System.Directory
import System.FilePath
import System.IO
import System.IO.Error ( isEOFError )
import Control.Monad ( when, forM_ )
import Data.Maybe ( isJust )
import Data.IORef
import qualified Data.Set as Set
-----------------------------------------------------------------
--
-- The main function
--
-----------------------------------------------------------------
doMkDependHS :: GhcMonad m => [FilePath] -> m ()
doMkDependHS srcs = do
logger <- getLogger
-- Initialisation
dflags0 <- GHC.getSessionDynFlags
-- We kludge things a bit for dependency generation. Rather than
-- generating dependencies for each way separately, we generate
-- them once and then duplicate them for each way's osuf/hisuf.
-- We therefore do the initial dependency generation with an empty
-- way and .o/.hi extensions, regardless of any flags that might
-- be specified.
let dflags1 = dflags0
{ targetWays_ = Set.empty
, hiSuf_ = "hi"
, objectSuf_ = "o"
}
GHC.setSessionDynFlags dflags1
-- If no suffix is provided, use the default -- the empty one
let dflags = if null (depSuffixes dflags1)
then dflags1 { depSuffixes = [""] }
else dflags1
tmpfs <- hsc_tmpfs <$> getSession
files <- liftIO $ beginMkDependHS logger tmpfs dflags
-- Do the downsweep to find all the modules
targets <- mapM (\s -> GHC.guessTarget s Nothing Nothing) srcs
GHC.setTargets targets
let excl_mods = depExcludeMods dflags
module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}
-- Sort into dependency order
-- There should be no cycles
let sorted = GHC.topSortModuleGraph False module_graph Nothing
-- Print out the dependencies if wanted
liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted)
-- Process them one by one, dumping results into makefile
-- and complaining about cycles
hsc_env <- getSession
root <- liftIO getCurrentDirectory
mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
-- If -ddump-mod-cycles, show cycles in the module graph
liftIO $ dumpModCycles logger module_graph
-- Tidy up
liftIO $ endMkDependHS logger files
-- Unconditional exiting is a bad idea. If an error occurs we'll get an
--exception; if that is not caught it's fine, but at least we have a
--chance to find out exactly what went wrong. Uncomment the following
--line if you disagree.
--`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
-----------------------------------------------------------------
--
-- beginMkDependHs
-- Create a temporary file,
-- find the Makefile,
-- slurp through it, etc
--
-----------------------------------------------------------------
data MkDepFiles
= MkDep { mkd_make_file :: FilePath, -- Name of the makefile
mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile
mkd_tmp_file :: FilePath, -- Name of the temporary file
mkd_tmp_hdl :: Handle } -- Handle of the open temporary file
beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles
beginMkDependHS logger tmpfs dflags = do
-- open a new temp file in which to stuff the dependency info
-- as we go along.
tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep"
tmp_hdl <- openFile tmp_file WriteMode
-- open the makefile
let makefile = depMakefile dflags
exists <- doesFileExist makefile
mb_make_hdl <-
if not exists
then return Nothing
else do
makefile_hdl <- openFile makefile ReadMode
-- slurp through until we get the magic start string,
-- copying the contents into dep_makefile
let slurp = do
l <- hGetLine makefile_hdl
if (l == depStartMarker)
then return ()
else do hPutStrLn tmp_hdl l; slurp
-- slurp through until we get the magic end marker,
-- throwing away the contents
let chuck = do
l <- hGetLine makefile_hdl
if (l == depEndMarker)
then return ()
else chuck
catchIO slurp
(\e -> if isEOFError e then return () else ioError e)
catchIO chuck
(\e -> if isEOFError e then return () else ioError e)
return (Just makefile_hdl)
-- write the magic marker into the tmp file
hPutStrLn tmp_hdl depStartMarker
return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl})
-----------------------------------------------------------------
--
-- processDeps
--
-----------------------------------------------------------------
processDeps :: DynFlags
-> HscEnv
-> [ModuleName]
-> FilePath
-> Handle -- Write dependencies to here
-> SCC ModuleGraphNode
-> IO ()
-- Write suitable dependencies to handle
-- Always:
-- this.o : this.hs
--
-- If the dependency is on something other than a .hi file:
-- this.o this.p_o ... : dep
-- otherwise
-- this.o ... : dep.hi
-- this.p_o ... : dep.p_hi
-- ...
-- (where .o is $osuf, and the other suffixes come from
-- the cmdline -s options).
--
-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
processDeps dflags _ _ _ _ (CyclicSCC nodes)
= -- There shouldn't be any cycles; report them
throwGhcExceptionIO $ ProgramError $
showSDoc dflags $ GHC.cyclicModuleErr nodes
processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode node))
= -- There shouldn't be any backpack instantiations; report them as well
throwGhcExceptionIO $ ProgramError $
showSDoc dflags $
vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"
, nest 2 $ ppr node ]
processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode (ExtendedModSummary node _)))
= do { let extra_suffixes = depSuffixes dflags
include_pkg_deps = depIncludePkgDeps dflags
src_file = msHsFilePath node
obj_file = msObjFilePath node
obj_files = insertSuffixes obj_file extra_suffixes
do_imp loc is_boot pkg_qual imp_mod
= do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod
is_boot include_pkg_deps
; case mb_hi of {
Nothing -> return () ;
Just hi_file -> do
{ let hi_files = insertSuffixes hi_file extra_suffixes
write_dep (obj,hi) = writeDependency root hdl [obj] hi
-- Add one dependency for each suffix;
-- e.g. A.o : B.hi
-- A.x_o : B.x_hi
; mapM_ write_dep (obj_files `zip` hi_files) }}}
-- Emit std dependency of the object(s) on the source file
-- Something like A.o : A.hs
; writeDependency root hdl obj_files src_file
-- add dependency between objects and their corresponding .hi-boot
-- files if the module has a corresponding .hs-boot file (#14482)
; when (isBootSummary node == IsBoot) $ do
let hi_boot = msHiFilePath node
let obj = removeBootSuffix (msObjFilePath node)
forM_ extra_suffixes $ \suff -> do
let way_obj = insertSuffixes obj [suff]
let way_hi_boot = insertSuffixes hi_boot [suff]
mapM_ (writeDependency root hdl way_obj) way_hi_boot
-- Emit a dependency for each CPP import
; when (depIncludeCppDeps dflags) $ do
-- CPP deps are descovered in the module parsing phase by parsing
-- comment lines left by the preprocessor.
-- Note that GHC.parseModule may throw an exception if the module
-- fails to parse, which may not be desirable (see #16616).
{ session <- Session <$> newIORef hsc_env
; parsedMod <- reflectGhc (GHC.parseModule node) session
; mapM_ (writeDependency root hdl obj_files)
(GHC.pm_extra_src_files parsedMod)
}
-- Emit a dependency for each import
; let do_imps is_boot idecls = sequence_
[ do_imp loc is_boot mb_pkg mod
| (mb_pkg, L loc mod) <- idecls,
mod `notElem` excl_mods ]
; do_imps IsBoot (ms_srcimps node)
; do_imps NotBoot (ms_imps node)
}
findDependency :: HscEnv
-> SrcSpan
-> PkgQual -- package qualifier, if any
-> ModuleName -- Imported module
-> IsBootInterface -- Source import
-> Bool -- Record dependency on package modules
-> IO (Maybe FilePath) -- Interface file
findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
let fc = hsc_FC hsc_env
let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
let units = hsc_units hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
-- Find the module; this will be fast because
-- we've done it once during downsweep
r <- findImportedModule fc fopts units mhome_unit imp pkg
case r of
Found loc _
-- Home package: just depend on the .hi or hi-boot file
| isJust (ml_hs_file loc) || include_pkg_deps
-> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
-- Not in this package: we don't need a dependency
| otherwise
-> return Nothing
fail ->
throwOneError $
mkPlainErrorMsgEnvelope srcloc $
GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $
cannotFindModule hsc_env imp fail
-----------------------------
writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
-- t1 t2 : dep
writeDependency root hdl targets dep
= do let -- We need to avoid making deps on
-- c:/foo/...
-- on cygwin as make gets confused by the :
-- Making relative deps avoids some instances of this.
dep' = makeRelative root dep
forOutput = escapeSpaces . reslash Forwards . normalise
output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
hPutStrLn hdl output
-----------------------------
insertSuffixes
:: FilePath -- Original filename; e.g. "foo.o"
-> [String] -- Suffix prefixes e.g. ["x_", "y_"]
-> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"]
-- Note that the extra bit gets inserted *before* the old suffix
-- We assume the old suffix contains no dots, so we know where to
-- split it
insertSuffixes file_name extras
= [ basename <.> (extra ++ suffix) | extra <- extras ]
where
(basename, suffix) = case splitExtension file_name of
-- Drop the "." from the extension
(b, s) -> (b, drop 1 s)
-----------------------------------------------------------------
--
-- endMkDependHs
-- Complete the makefile, close the tmp file etc
--
-----------------------------------------------------------------
endMkDependHS :: Logger -> MkDepFiles -> IO ()
endMkDependHS logger
(MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl,
mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl })
= do
-- write the magic marker into the tmp file
hPutStrLn tmp_hdl depEndMarker
case makefile_hdl of
Nothing -> return ()
Just hdl -> do
-- slurp the rest of the original makefile and copy it into the output
SysTools.copyHandle hdl tmp_hdl
hClose hdl
hClose tmp_hdl -- make sure it's flushed
-- Create a backup of the original makefile
when (isJust makefile_hdl) $ do
showPass logger ("Backing up " ++ makefile)
SysTools.copyFile makefile (makefile++".bak")
-- Copy the new makefile in place
showPass logger "Installing new makefile"
SysTools.copyFile tmp_file makefile
-----------------------------------------------------------------
-- Module cycles
-----------------------------------------------------------------
dumpModCycles :: Logger -> ModuleGraph -> IO ()
dumpModCycles logger module_graph
| not (logHasDumpFlag logger Opt_D_dump_mod_cycles)
= return ()
| null cycles
= putMsg logger (text "No module cycles")
| otherwise
= putMsg logger (hang (text "Module cycles found:") 2 pp_cycles)
where
topoSort = filterToposortToModules $
GHC.topSortModuleGraph True module_graph Nothing
cycles :: [[ModSummary]]
cycles =
[ c | CyclicSCC c <- topoSort ]
pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> text "----------")
$$ pprCycle c $$ blankLine
| (n,c) <- [1..] `zip` cycles ]
pprCycle :: [ModSummary] -> SDoc
-- Print a cycle, but show only the imports within the cycle
pprCycle summaries = pp_group (CyclicSCC summaries)
where
cycle_mods :: [ModuleName] -- The modules in this cycle
cycle_mods = map (moduleName . ms_mod) summaries
pp_group (AcyclicSCC ms) = pp_ms ms
pp_group (CyclicSCC mss)
= assert (not (null boot_only)) $
-- The boot-only list must be non-empty, else there would
-- be an infinite chain of non-boot imports, and we've
-- already checked for that in processModDeps
pp_ms loop_breaker $$ vcat (map pp_group groups)
where
(boot_only, others) = partition is_boot_only mss
is_boot_only ms = not (any in_group (map snd (ms_imps ms)))
in_group (L _ m) = m `elem` group_mods
group_mods = map (moduleName . ms_mod) mss
loop_breaker = head boot_only
all_others = tail boot_only ++ others
groups = filterToposortToModules $
GHC.topSortModuleGraph True (mkModuleGraph $ extendModSummaryNoDeps <$> all_others) Nothing
pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
<+> (pp_imps empty (map snd (ms_imps summary)) $$
pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))
where
mod_str = moduleNameString (moduleName (ms_mod summary))
pp_imps :: SDoc -> [Located ModuleName] -> SDoc
pp_imps _ [] = empty
pp_imps what lms
= case [m | L _ m <- lms, m `elem` cycle_mods] of
[] -> empty
ms -> what <+> text "imports" <+>
pprWithCommas ppr ms
-----------------------------------------------------------------
--
-- Flags
--
-----------------------------------------------------------------
depStartMarker, depEndMarker :: String
depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"
|