aae4d0e7c2753518d3939758bbb0ccae2d37941c
[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 | Just src_file <- msHsFilePath node
203 = do { let extra_suffixes = depSuffixes dflags
204 include_pkg_deps = depIncludePkgDeps dflags
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 | otherwise
240 = ASSERT( ms_hsc_src node == HsBootMerge )
241 panic "HsBootMerge not supported in DriverMkDepend yet"
242
243
244 findDependency :: HscEnv
245 -> SrcSpan
246 -> Maybe FastString -- package qualifier, if any
247 -> ModuleName -- Imported module
248 -> IsBootInterface -- Source import
249 -> Bool -- Record dependency on package modules
250 -> IO (Maybe FilePath) -- Interface file file
251 findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
252 = do { -- Find the module; this will be fast because
253 -- we've done it once during downsweep
254 r <- findImportedModule hsc_env imp pkg
255 ; case r of
256 Found loc _
257 -- Home package: just depend on the .hi or hi-boot file
258 | isJust (ml_hs_file loc) || include_pkg_deps
259 -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
260
261 -- Not in this package: we don't need a dependency
262 | otherwise
263 -> return Nothing
264
265 fail ->
266 let dflags = hsc_dflags hsc_env
267 in throwOneError $ mkPlainErrMsg dflags srcloc $
268 cannotFindModule dflags imp fail
269 }
270
271 -----------------------------
272 writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
273 -- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
274 -- t1 t2 : dep
275 writeDependency root hdl targets dep
276 = do let -- We need to avoid making deps on
277 -- c:/foo/...
278 -- on cygwin as make gets confused by the :
279 -- Making relative deps avoids some instances of this.
280 dep' = makeRelative root dep
281 forOutput = escapeSpaces . reslash Forwards . normalise
282 output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
283 hPutStrLn hdl output
284
285 -----------------------------
286 insertSuffixes
287 :: FilePath -- Original filename; e.g. "foo.o"
288 -> [String] -- Suffix prefixes e.g. ["x_", "y_"]
289 -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"]
290 -- Note that that the extra bit gets inserted *before* the old suffix
291 -- We assume the old suffix contains no dots, so we know where to
292 -- split it
293 insertSuffixes file_name extras
294 = [ basename <.> (extra ++ suffix) | extra <- extras ]
295 where
296 (basename, suffix) = case splitExtension file_name of
297 -- Drop the "." from the extension
298 (b, s) -> (b, drop 1 s)
299
300
301 -----------------------------------------------------------------
302 --
303 -- endMkDependHs
304 -- Complete the makefile, close the tmp file etc
305 --
306 -----------------------------------------------------------------
307
308 endMkDependHS :: DynFlags -> MkDepFiles -> IO ()
309
310 endMkDependHS dflags
311 (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl,
312 mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl })
313 = do
314 -- write the magic marker into the tmp file
315 hPutStrLn tmp_hdl depEndMarker
316
317 case makefile_hdl of
318 Nothing -> return ()
319 Just hdl -> do
320
321 -- slurp the rest of the original makefile and copy it into the output
322 let slurp = do
323 l <- hGetLine hdl
324 hPutStrLn tmp_hdl l
325 slurp
326
327 catchIO slurp
328 (\e -> if isEOFError e then return () else ioError e)
329
330 hClose hdl
331
332 hClose tmp_hdl -- make sure it's flushed
333
334 -- Create a backup of the original makefile
335 when (isJust makefile_hdl)
336 (SysTools.copy dflags ("Backing up " ++ makefile)
337 makefile (makefile++".bak"))
338
339 -- Copy the new makefile in place
340 SysTools.copy dflags "Installing new makefile" tmp_file makefile
341
342
343 -----------------------------------------------------------------
344 -- Module cycles
345 -----------------------------------------------------------------
346
347 dumpModCycles :: DynFlags -> [ModSummary] -> IO ()
348 dumpModCycles dflags mod_summaries
349 | not (dopt Opt_D_dump_mod_cycles dflags)
350 = return ()
351
352 | null cycles
353 = putMsg dflags (ptext (sLit "No module cycles"))
354
355 | otherwise
356 = putMsg dflags (hang (ptext (sLit "Module cycles found:")) 2 pp_cycles)
357 where
358
359 cycles :: [[ModSummary]]
360 cycles = [ c | CyclicSCC c <- GHC.topSortModuleGraph True mod_summaries Nothing ]
361
362 pp_cycles = vcat [ (ptext (sLit "---------- Cycle") <+> int n <+> ptext (sLit "----------"))
363 $$ pprCycle c $$ blankLine
364 | (n,c) <- [1..] `zip` cycles ]
365
366 pprCycle :: [ModSummary] -> SDoc
367 -- Print a cycle, but show only the imports within the cycle
368 pprCycle summaries = pp_group (CyclicSCC summaries)
369 where
370 cycle_mods :: [ModuleName] -- The modules in this cycle
371 cycle_mods = map (moduleName . ms_mod) summaries
372
373 pp_group (AcyclicSCC ms) = pp_ms ms
374 pp_group (CyclicSCC mss)
375 = ASSERT( not (null boot_only) )
376 -- The boot-only list must be non-empty, else there would
377 -- be an infinite chain of non-boot imoprts, and we've
378 -- already checked for that in processModDeps
379 pp_ms loop_breaker $$ vcat (map pp_group groups)
380 where
381 (boot_only, others) = partition is_boot_only mss
382 is_boot_only ms = not (any in_group (map (ideclName.unLoc) (ms_imps ms)))
383 in_group (L _ m) = m `elem` group_mods
384 group_mods = map (moduleName . ms_mod) mss
385
386 loop_breaker = head boot_only
387 all_others = tail boot_only ++ others
388 groups = GHC.topSortModuleGraph True all_others Nothing
389
390 pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
391 <+> (pp_imps empty (map (ideclName.unLoc) (ms_imps summary)) $$
392 pp_imps (ptext (sLit "{-# SOURCE #-}")) (map (ideclName.unLoc) (ms_srcimps summary)))
393 where
394 mod_str = moduleNameString (moduleName (ms_mod summary))
395
396 pp_imps :: SDoc -> [Located ModuleName] -> SDoc
397 pp_imps _ [] = empty
398 pp_imps what lms
399 = case [m | L _ m <- lms, m `elem` cycle_mods] of
400 [] -> empty
401 ms -> what <+> ptext (sLit "imports") <+>
402 pprWithCommas ppr ms
403
404 -----------------------------------------------------------------
405 --
406 -- Flags
407 --
408 -----------------------------------------------------------------
409
410 depStartMarker, depEndMarker :: String
411 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
412 depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"
413