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