Revert "Revert "Revert "Support for multiple signature files in scope."""
[ghc.git] / compiler / main / DriverMkDepend.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Makefile Dependency Generation
6 --
7 -- (c) The University of Glasgow 2005
8 --
9 -----------------------------------------------------------------------------
10
11 module DriverMkDepend (
12 doMkDependHS
13 ) where
14
15 #include "HsVersions.h"
16
17 import qualified GHC
18 import GhcMonad
19 import HsSyn ( ImportDecl(..) )
20 import DynFlags
21 import Util
22 import HscTypes
23 import SysTools ( newTempName )
24 import qualified SysTools
25 import Module
26 import Digraph ( SCC(..) )
27 import Finder
28 import Outputable
29 import Panic
30 import SrcLoc
31 import Data.List
32 import FastString
33 import BasicTypes ( StringLiteral(..) )
34
35 import Exception
36 import ErrUtils
37
38 import System.Directory
39 import System.FilePath
40 import System.IO
41 import System.IO.Error ( isEOFError )
42 import Control.Monad ( when )
43 import Data.Maybe ( isJust )
44
45 -----------------------------------------------------------------
46 --
47 -- The main function
48 --
49 -----------------------------------------------------------------
50
51 doMkDependHS :: GhcMonad m => [FilePath] -> m ()
52 doMkDependHS srcs = do
53 -- Initialisation
54 dflags0 <- GHC.getSessionDynFlags
55
56 -- We kludge things a bit for dependency generation. Rather than
57 -- generating dependencies for each way separately, we generate
58 -- them once and then duplicate them for each way's osuf/hisuf.
59 -- We therefore do the initial dependency generation with an empty
60 -- way and .o/.hi extensions, regardless of any flags that might
61 -- be specified.
62 let dflags = dflags0 {
63 ways = [],
64 buildTag = mkBuildTag [],
65 hiSuf = "hi",
66 objectSuf = "o"
67 }
68 _ <- GHC.setSessionDynFlags dflags
69
70 when (null (depSuffixes dflags)) $ liftIO $
71 throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")
72
73 files <- liftIO $ beginMkDependHS dflags
74
75 -- Do the downsweep to find all the modules
76 targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs
77 GHC.setTargets targets
78 let excl_mods = depExcludeMods dflags
79 mod_summaries <- GHC.depanal excl_mods True {- Allow dup roots -}
80
81 -- Sort into dependency order
82 -- There should be no cycles
83 let sorted = GHC.topSortModuleGraph False mod_summaries Nothing
84
85 -- Print out the dependencies if wanted
86 liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)
87
88 -- Prcess them one by one, dumping results into makefile
89 -- and complaining about cycles
90 hsc_env <- getSession
91 root <- liftIO getCurrentDirectory
92 mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
93
94 -- If -ddump-mod-cycles, show cycles in the module graph
95 liftIO $ dumpModCycles dflags mod_summaries
96
97 -- Tidy up
98 liftIO $ endMkDependHS dflags files
99
100 -- Unconditional exiting is a bad idea. If an error occurs we'll get an
101 --exception; if that is not caught it's fine, but at least we have a
102 --chance to find out exactly what went wrong. Uncomment the following
103 --line if you disagree.
104
105 --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
106
107 -----------------------------------------------------------------
108 --
109 -- beginMkDependHs
110 -- Create a temporary file,
111 -- find the Makefile,
112 -- slurp through it, etc
113 --
114 -----------------------------------------------------------------
115
116 data MkDepFiles
117 = MkDep { mkd_make_file :: FilePath, -- Name of the makefile
118 mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile
119 mkd_tmp_file :: FilePath, -- Name of the temporary file
120 mkd_tmp_hdl :: Handle } -- Handle of the open temporary file
121
122 beginMkDependHS :: DynFlags -> IO MkDepFiles
123 beginMkDependHS dflags = do
124 -- open a new temp file in which to stuff the dependency info
125 -- as we go along.
126 tmp_file <- newTempName dflags "dep"
127 tmp_hdl <- openFile tmp_file WriteMode
128
129 -- open the makefile
130 let makefile = depMakefile dflags
131 exists <- doesFileExist makefile
132 mb_make_hdl <-
133 if not exists
134 then return Nothing
135 else do
136 makefile_hdl <- openFile makefile ReadMode
137
138 -- slurp through until we get the magic start string,
139 -- copying the contents into dep_makefile
140 let slurp = do
141 l <- hGetLine makefile_hdl
142 if (l == depStartMarker)
143 then return ()
144 else do hPutStrLn tmp_hdl l; slurp
145
146 -- slurp through until we get the magic end marker,
147 -- throwing away the contents
148 let chuck = do
149 l <- hGetLine makefile_hdl
150 if (l == depEndMarker)
151 then return ()
152 else chuck
153
154 catchIO slurp
155 (\e -> if isEOFError e then return () else ioError e)
156 catchIO chuck
157 (\e -> if isEOFError e then return () else ioError e)
158
159 return (Just makefile_hdl)
160
161
162 -- write the magic marker into the tmp file
163 hPutStrLn tmp_hdl depStartMarker
164
165 return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
166 mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl})
167
168
169 -----------------------------------------------------------------
170 --
171 -- processDeps
172 --
173 -----------------------------------------------------------------
174
175 processDeps :: DynFlags
176 -> HscEnv
177 -> [ModuleName]
178 -> FilePath
179 -> Handle -- Write dependencies to here
180 -> SCC ModSummary
181 -> IO ()
182 -- Write suitable dependencies to handle
183 -- Always:
184 -- this.o : this.hs
185 --
186 -- If the dependency is on something other than a .hi file:
187 -- this.o this.p_o ... : dep
188 -- otherwise
189 -- this.o ... : dep.hi
190 -- this.p_o ... : dep.p_hi
191 -- ...
192 -- (where .o is $osuf, and the other suffixes come from
193 -- the cmdline -s options).
194 --
195 -- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
196
197 processDeps dflags _ _ _ _ (CyclicSCC nodes)
198 = -- There shouldn't be any cycles; report them
199 throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
200
201 processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
202 = do { let extra_suffixes = depSuffixes dflags
203 include_pkg_deps = depIncludePkgDeps dflags
204 src_file = msHsFilePath node
205 obj_file = msObjFilePath node
206 obj_files = insertSuffixes obj_file extra_suffixes
207
208 do_imp loc is_boot pkg_qual imp_mod
209 = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod
210 is_boot include_pkg_deps
211 ; case mb_hi of {
212 Nothing -> return () ;
213 Just hi_file -> do
214 { let hi_files = insertSuffixes hi_file extra_suffixes
215 write_dep (obj,hi) = writeDependency root hdl [obj] hi
216
217 -- Add one dependency for each suffix;
218 -- e.g. A.o : B.hi
219 -- A.x_o : B.x_hi
220 ; mapM_ write_dep (obj_files `zip` hi_files) }}}
221
222
223 -- Emit std dependency of the object(s) on the source file
224 -- Something like A.o : A.hs
225 ; writeDependency root hdl obj_files src_file
226
227 -- Emit a dependency for each import
228
229 ; let do_imps is_boot idecls = sequence_
230 [ do_imp loc is_boot (fmap sl_fs $ ideclPkgQual i) mod
231 | L loc i <- idecls,
232 let mod = unLoc (ideclName i),
233 mod `notElem` excl_mods ]
234
235 ; do_imps True (ms_srcimps node)
236 ; do_imps False (ms_imps node)
237 }
238
239
240 findDependency :: HscEnv
241 -> SrcSpan
242 -> Maybe FastString -- package qualifier, if any
243 -> ModuleName -- Imported module
244 -> IsBootInterface -- Source import
245 -> Bool -- Record dependency on package modules
246 -> IO (Maybe FilePath) -- Interface file file
247 findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
248 = do { -- Find the module; this will be fast because
249 -- we've done it once during downsweep
250 r <- findImportedModule hsc_env imp pkg
251 ; case r of
252 Found loc _
253 -- Home package: just depend on the .hi or hi-boot file
254 | isJust (ml_hs_file loc) || include_pkg_deps
255 -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
256
257 -- Not in this package: we don't need a dependency
258 | otherwise
259 -> return Nothing
260
261 fail ->
262 let dflags = hsc_dflags hsc_env
263 in throwOneError $ mkPlainErrMsg dflags srcloc $
264 cannotFindModule dflags imp fail
265 }
266
267 -----------------------------
268 writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
269 -- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
270 -- t1 t2 : dep
271 writeDependency root hdl targets dep
272 = do let -- We need to avoid making deps on
273 -- c:/foo/...
274 -- on cygwin as make gets confused by the :
275 -- Making relative deps avoids some instances of this.
276 dep' = makeRelative root dep
277 forOutput = escapeSpaces . reslash Forwards . normalise
278 output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
279 hPutStrLn hdl output
280
281 -----------------------------
282 insertSuffixes
283 :: FilePath -- Original filename; e.g. "foo.o"
284 -> [String] -- Suffix prefixes e.g. ["x_", "y_"]
285 -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"]
286 -- Note that that the extra bit gets inserted *before* the old suffix
287 -- We assume the old suffix contains no dots, so we know where to
288 -- split it
289 insertSuffixes file_name extras
290 = [ basename <.> (extra ++ suffix) | extra <- extras ]
291 where
292 (basename, suffix) = case splitExtension file_name of
293 -- Drop the "." from the extension
294 (b, s) -> (b, drop 1 s)
295
296
297 -----------------------------------------------------------------
298 --
299 -- endMkDependHs
300 -- Complete the makefile, close the tmp file etc
301 --
302 -----------------------------------------------------------------
303
304 endMkDependHS :: DynFlags -> MkDepFiles -> IO ()
305
306 endMkDependHS dflags
307 (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl,
308 mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl })
309 = do
310 -- write the magic marker into the tmp file
311 hPutStrLn tmp_hdl depEndMarker
312
313 case makefile_hdl of
314 Nothing -> return ()
315 Just hdl -> do
316
317 -- slurp the rest of the original makefile and copy it into the output
318 let slurp = do
319 l <- hGetLine hdl
320 hPutStrLn tmp_hdl l
321 slurp
322
323 catchIO slurp
324 (\e -> if isEOFError e then return () else ioError e)
325
326 hClose hdl
327
328 hClose tmp_hdl -- make sure it's flushed
329
330 -- Create a backup of the original makefile
331 when (isJust makefile_hdl)
332 (SysTools.copy dflags ("Backing up " ++ makefile)
333 makefile (makefile++".bak"))
334
335 -- Copy the new makefile in place
336 SysTools.copy dflags "Installing new makefile" tmp_file makefile
337
338
339 -----------------------------------------------------------------
340 -- Module cycles
341 -----------------------------------------------------------------
342
343 dumpModCycles :: DynFlags -> [ModSummary] -> IO ()
344 dumpModCycles dflags mod_summaries
345 | not (dopt Opt_D_dump_mod_cycles dflags)
346 = return ()
347
348 | null cycles
349 = putMsg dflags (ptext (sLit "No module cycles"))
350
351 | otherwise
352 = putMsg dflags (hang (ptext (sLit "Module cycles found:")) 2 pp_cycles)
353 where
354
355 cycles :: [[ModSummary]]
356 cycles = [ c | CyclicSCC c <- GHC.topSortModuleGraph True mod_summaries Nothing ]
357
358 pp_cycles = vcat [ (ptext (sLit "---------- Cycle") <+> int n <+> ptext (sLit "----------"))
359 $$ pprCycle c $$ blankLine
360 | (n,c) <- [1..] `zip` cycles ]
361
362 pprCycle :: [ModSummary] -> SDoc
363 -- Print a cycle, but show only the imports within the cycle
364 pprCycle summaries = pp_group (CyclicSCC summaries)
365 where
366 cycle_mods :: [ModuleName] -- The modules in this cycle
367 cycle_mods = map (moduleName . ms_mod) summaries
368
369 pp_group (AcyclicSCC ms) = pp_ms ms
370 pp_group (CyclicSCC mss)
371 = ASSERT( not (null boot_only) )
372 -- The boot-only list must be non-empty, else there would
373 -- be an infinite chain of non-boot imoprts, and we've
374 -- already checked for that in processModDeps
375 pp_ms loop_breaker $$ vcat (map pp_group groups)
376 where
377 (boot_only, others) = partition is_boot_only mss
378 is_boot_only ms = not (any in_group (map (ideclName.unLoc) (ms_imps ms)))
379 in_group (L _ m) = m `elem` group_mods
380 group_mods = map (moduleName . ms_mod) mss
381
382 loop_breaker = head boot_only
383 all_others = tail boot_only ++ others
384 groups = GHC.topSortModuleGraph True all_others Nothing
385
386 pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
387 <+> (pp_imps empty (map (ideclName.unLoc) (ms_imps summary)) $$
388 pp_imps (ptext (sLit "{-# SOURCE #-}")) (map (ideclName.unLoc) (ms_srcimps summary)))
389 where
390 mod_str = moduleNameString (moduleName (ms_mod summary))
391
392 pp_imps :: SDoc -> [Located ModuleName] -> SDoc
393 pp_imps _ [] = empty
394 pp_imps what lms
395 = case [m | L _ m <- lms, m `elem` cycle_mods] of
396 [] -> empty
397 ms -> what <+> ptext (sLit "imports") <+>
398 pprWithCommas ppr ms
399
400 -----------------------------------------------------------------
401 --
402 -- Flags
403 --
404 -----------------------------------------------------------------
405
406 depStartMarker, depEndMarker :: String
407 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
408 depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"
409