compiler: Write .o files atomically. See #14533
[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 GhcPrelude
18
19 import qualified GHC
20 import GhcMonad
21 import DynFlags
22 import Util
23 import HscTypes
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 FileCleanup
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 module_graph <- 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 module_graph 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 module_graph
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 TFL_CurrentModule "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 mb_pkg mod
231 | (mb_pkg, L loc mod) <- idecls,
232 mod `notElem` excl_mods ]
233
234 ; do_imps True (ms_srcimps node)
235 ; do_imps False (ms_imps node)
236 }
237
238
239 findDependency :: HscEnv
240 -> SrcSpan
241 -> Maybe FastString -- package qualifier, if any
242 -> ModuleName -- Imported module
243 -> IsBootInterface -- Source import
244 -> Bool -- Record dependency on package modules
245 -> IO (Maybe FilePath) -- Interface file file
246 findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
247 = do { -- Find the module; this will be fast because
248 -- we've done it once during downsweep
249 r <- findImportedModule hsc_env imp pkg
250 ; case r of
251 Found loc _
252 -- Home package: just depend on the .hi or hi-boot file
253 | isJust (ml_hs_file loc) || include_pkg_deps
254 -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
255
256 -- Not in this package: we don't need a dependency
257 | otherwise
258 -> return Nothing
259
260 fail ->
261 let dflags = hsc_dflags hsc_env
262 in throwOneError $ mkPlainErrMsg dflags srcloc $
263 cannotFindModule dflags imp fail
264 }
265
266 -----------------------------
267 writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
268 -- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
269 -- t1 t2 : dep
270 writeDependency root hdl targets dep
271 = do let -- We need to avoid making deps on
272 -- c:/foo/...
273 -- on cygwin as make gets confused by the :
274 -- Making relative deps avoids some instances of this.
275 dep' = makeRelative root dep
276 forOutput = escapeSpaces . reslash Forwards . normalise
277 output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
278 hPutStrLn hdl output
279
280 -----------------------------
281 insertSuffixes
282 :: FilePath -- Original filename; e.g. "foo.o"
283 -> [String] -- Suffix prefixes e.g. ["x_", "y_"]
284 -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"]
285 -- Note that that the extra bit gets inserted *before* the old suffix
286 -- We assume the old suffix contains no dots, so we know where to
287 -- split it
288 insertSuffixes file_name extras
289 = [ basename <.> (extra ++ suffix) | extra <- extras ]
290 where
291 (basename, suffix) = case splitExtension file_name of
292 -- Drop the "." from the extension
293 (b, s) -> (b, drop 1 s)
294
295
296 -----------------------------------------------------------------
297 --
298 -- endMkDependHs
299 -- Complete the makefile, close the tmp file etc
300 --
301 -----------------------------------------------------------------
302
303 endMkDependHS :: DynFlags -> MkDepFiles -> IO ()
304
305 endMkDependHS dflags
306 (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl,
307 mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl })
308 = do
309 -- write the magic marker into the tmp file
310 hPutStrLn tmp_hdl depEndMarker
311
312 case makefile_hdl of
313 Nothing -> return ()
314 Just hdl -> do
315
316 -- slurp the rest of the original makefile and copy it into the output
317 let slurp = do
318 l <- hGetLine hdl
319 hPutStrLn tmp_hdl l
320 slurp
321
322 catchIO slurp
323 (\e -> if isEOFError e then return () else ioError e)
324
325 hClose hdl
326
327 hClose tmp_hdl -- make sure it's flushed
328
329 -- Create a backup of the original makefile
330 when (isJust makefile_hdl)
331 (SysTools.copy dflags ("Backing up " ++ makefile)
332 makefile (makefile++".bak"))
333
334 -- Copy the new makefile in place
335 SysTools.copy dflags "Installing new makefile" tmp_file makefile
336
337
338 -----------------------------------------------------------------
339 -- Module cycles
340 -----------------------------------------------------------------
341
342 dumpModCycles :: DynFlags -> ModuleGraph -> IO ()
343 dumpModCycles dflags module_graph
344 | not (dopt Opt_D_dump_mod_cycles dflags)
345 = return ()
346
347 | null cycles
348 = putMsg dflags (text "No module cycles")
349
350 | otherwise
351 = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles)
352 where
353
354 cycles :: [[ModSummary]]
355 cycles =
356 [ c | CyclicSCC c <- GHC.topSortModuleGraph True module_graph Nothing ]
357
358 pp_cycles = vcat [ (text "---------- 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 snd (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 =
385 GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing
386
387 pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
388 <+> (pp_imps empty (map snd (ms_imps summary)) $$
389 pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))
390 where
391 mod_str = moduleNameString (moduleName (ms_mod summary))
392
393 pp_imps :: SDoc -> [Located ModuleName] -> SDoc
394 pp_imps _ [] = empty
395 pp_imps what lms
396 = case [m | L _ m <- lms, m `elem` cycle_mods] of
397 [] -> empty
398 ms -> what <+> text "imports" <+>
399 pprWithCommas ppr ms
400
401 -----------------------------------------------------------------
402 --
403 -- Flags
404 --
405 -----------------------------------------------------------------
406
407 depStartMarker, depEndMarker :: String
408 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
409 depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"
410