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