DriverMkDepend.hs 14.9 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}

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 16

#include "HsVersions.h"

17 18
import GhcPrelude

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 31
import SrcLoc
import Data.List
32
import FastString
duog's avatar
duog committed
33
import FileCleanup
34

35
import Exception
36
import ErrUtils
37

Simon Marlow's avatar
Simon Marlow committed
38
import System.Directory
Ian Lynagh's avatar
Ian Lynagh committed
39
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
40
import System.IO
41
import System.IO.Error  ( isEOFError )
Simon Marlow's avatar
Simon Marlow committed
42 43
import Control.Monad    ( when )
import Data.Maybe       ( isJust )
44
import Data.IORef
45

46 47
-----------------------------------------------------------------
--
48
--              The main function
49 50 51
--
-----------------------------------------------------------------

52 53 54
doMkDependHS :: GhcMonad m => [FilePath] -> m ()
doMkDependHS srcs = do
    -- Initialisation
55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70
    dflags0 <- GHC.getSessionDynFlags

    -- We kludge things a bit for dependency generation. Rather than
    -- generating dependencies for each way separately, we generate
    -- them once and then duplicate them for each way's osuf/hisuf.
    -- We therefore do the initial dependency generation with an empty
    -- way and .o/.hi extensions, regardless of any flags that might
    -- be specified.
    let dflags = dflags0 {
                     ways = [],
                     buildTag = mkBuildTag [],
                     hiSuf = "hi",
                     objectSuf = "o"
                 }
    _ <- GHC.setSessionDynFlags dflags

71 72
    when (null (depSuffixes dflags)) $ liftIO $
        throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")
73

74
    files <- liftIO $ beginMkDependHS dflags
75

76 77 78 79
    -- Do the downsweep to find all the modules
    targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs
    GHC.setTargets targets
    let excl_mods = depExcludeMods dflags
80
    module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}
81

82 83
    -- Sort into dependency order
    -- There should be no cycles
84
    let sorted = GHC.topSortModuleGraph False module_graph Nothing
85

86 87
    -- Print out the dependencies if wanted
    liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)
88

89
    -- Process them one by one, dumping results into makefile
90 91
    -- and complaining about cycles
    hsc_env <- getSession
92
    root <- liftIO getCurrentDirectory
93
    mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
94

95
    -- If -ddump-mod-cycles, show cycles in the module graph
96
    liftIO $ dumpModCycles dflags module_graph
97

98 99 100 101 102 103 104 105 106
    -- Tidy up
    liftIO $ endMkDependHS dflags files

    -- Unconditional exiting is a bad idea.  If an error occurs we'll get an
    --exception; if that is not caught it's fine, but at least we have a
    --chance to find out exactly what went wrong.  Uncomment the following
    --line if you disagree.

    --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
107 108 109

-----------------------------------------------------------------
--
110 111 112 113
--              beginMkDependHs
--      Create a temporary file,
--      find the Makefile,
--      slurp through it, etc
114 115
--
-----------------------------------------------------------------
116

117 118 119 120 121
data MkDepFiles
  = MkDep { mkd_make_file :: FilePath,          -- Name of the makefile
            mkd_make_hdl  :: Maybe Handle,      -- Handle for the open makefile
            mkd_tmp_file  :: FilePath,          -- Name of the temporary file
            mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file
122

123 124
beginMkDependHS :: DynFlags -> IO MkDepFiles
beginMkDependHS dflags = do
125 126
        -- open a new temp file in which to stuff the dependency info
        -- as we go along.
duog's avatar
duog committed
127
  tmp_file <- newTempName dflags TFL_CurrentModule "dep"
128
  tmp_hdl <- openFile tmp_file WriteMode
129

130
        -- open the makefile
131
  let makefile = depMakefile dflags
132
  exists <- doesFileExist makefile
133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
  mb_make_hdl <-
        if not exists
        then return Nothing
        else do
           makefile_hdl <- openFile makefile ReadMode

                -- slurp through until we get the magic start string,
                -- copying the contents into dep_makefile
           let slurp = do
                l <- hGetLine makefile_hdl
                if (l == depStartMarker)
                        then return ()
                        else do hPutStrLn tmp_hdl l; slurp

                -- slurp through until we get the magic end marker,
                -- throwing away the contents
           let chuck = do
                l <- hGetLine makefile_hdl
                if (l == depEndMarker)
                        then return ()
                        else chuck

155
           catchIO slurp
156
                (\e -> if isEOFError e then return () else ioError e)
157
           catchIO chuck
158 159 160 161 162 163
                (\e -> if isEOFError e then return () else ioError e)

           return (Just makefile_hdl)


        -- write the magic marker into the tmp file
164 165
  hPutStrLn tmp_hdl depStartMarker

166 167
  return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
                  mkd_tmp_file  = tmp_file, mkd_tmp_hdl  = tmp_hdl})
168

169

170 171
-----------------------------------------------------------------
--
172
--              processDeps
173 174 175
--
-----------------------------------------------------------------

176
processDeps :: DynFlags
177
            -> HscEnv
178
            -> [ModuleName]
179
            -> FilePath
180 181 182
            -> Handle           -- Write dependencies to here
            -> SCC ModSummary
            -> IO ()
183 184
-- Write suitable dependencies to handle
-- Always:
185
--                      this.o : this.hs
186 187
--
-- If the dependency is on something other than a .hi file:
188
--                      this.o this.p_o ... : dep
189
-- otherwise
190 191 192
--                      this.o ...   : dep.hi
--                      this.p_o ... : dep.p_hi
--                      ...
193 194 195 196 197
-- (where .o is $osuf, and the other suffixes come from
-- the cmdline -s options).
--
-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".

198
processDeps dflags _ _ _ _ (CyclicSCC nodes)
199
  =     -- There shouldn't be any cycles; report them
200
    throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
201

202
processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
203
  = do  { let extra_suffixes = depSuffixes dflags
204
              include_pkg_deps = depIncludePkgDeps dflags
205
              src_file  = msHsFilePath node
206 207 208
              obj_file  = msObjFilePath node
              obj_files = insertSuffixes obj_file extra_suffixes

209 210
              do_imp loc is_boot pkg_qual imp_mod
                = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod
211 212 213 214 215
                                               is_boot include_pkg_deps
                     ; case mb_hi of {
                           Nothing      -> return () ;
                           Just hi_file -> do
                     { let hi_files = insertSuffixes hi_file extra_suffixes
216
                           write_dep (obj,hi) = writeDependency root hdl [obj] hi
217 218 219 220 221 222 223 224 225

                        -- Add one dependency for each suffix;
                        -- e.g.         A.o   : B.hi
                        --              A.x_o : B.x_hi
                     ; mapM_ write_dep (obj_files `zip` hi_files) }}}


                -- Emit std dependency of the object(s) on the source file
                -- Something like       A.o : A.hs
226
        ; writeDependency root hdl obj_files src_file
227

228 229 230 231 232 233 234 235 236 237 238 239
                -- Emit a dependency for each CPP import
        ; when (depIncludeCppDeps dflags) $ do
            -- CPP deps are descovered in the module parsing phase by parsing
            -- comment lines left by the preprocessor.
            -- Note that GHC.parseModule may throw an exception if the module
            -- fails to parse, which may not be desirable (see #16616).
          { session <- Session <$> newIORef hsc_env
          ; parsedMod <- reflectGhc (GHC.parseModule node) session
          ; mapM_ (writeDependency root hdl obj_files)
                  (GHC.pm_extra_src_files parsedMod)
          }

240 241
                -- Emit a dependency for each import

242
        ; let do_imps is_boot idecls = sequence_
243 244
                    [ do_imp loc is_boot mb_pkg mod
                    | (mb_pkg, L loc mod) <- idecls,
245
                      mod `notElem` excl_mods ]
246

247 248
        ; do_imps True  (ms_srcimps node)
        ; do_imps False (ms_imps node)
249 250 251 252
        }


findDependency  :: HscEnv
253
                -> SrcSpan
254
                -> Maybe FastString     -- package qualifier, if any
255 256 257 258
                -> ModuleName           -- Imported module
                -> IsBootInterface      -- Source import
                -> Bool                 -- Record dependency on package modules
                -> IO (Maybe FilePath)  -- Interface file file
259
findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
260 261
  = do  {       -- Find the module; this will be fast because
                -- we've done it once during downsweep
262
          r <- findImportedModule hsc_env imp pkg
263
        ; case r of
264
            Found loc _
265
                -- Home package: just depend on the .hi or hi-boot file
266
                | isJust (ml_hs_file loc) || include_pkg_deps
267 268 269 270 271 272
                -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))

                -- Not in this package: we don't need a dependency
                | otherwise
                -> return Nothing

273 274 275 276
            fail ->
                let dflags = hsc_dflags hsc_env
                in throwOneError $ mkPlainErrMsg dflags srcloc $
                        cannotFindModule dflags imp fail
277
        }
278 279

-----------------------------
280 281
writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
282
--      t1 t2 : dep
283 284 285 286 287 288 289 290 291
writeDependency root hdl targets dep
  = do let -- We need to avoid making deps on
           --     c:/foo/...
           -- on cygwin as make gets confused by the :
           -- Making relative deps avoids some instances of this.
           dep' = makeRelative root dep
           forOutput = escapeSpaces . reslash Forwards . normalise
           output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
       hPutStrLn hdl output
292 293

-----------------------------
294 295
insertSuffixes
        :: FilePath     -- Original filename;   e.g. "foo.o"
296 297
        -> [String]     -- Suffix prefixes      e.g. ["x_", "y_"]
        -> [FilePath]   -- Zapped filenames     e.g. ["foo.x_o", "foo.y_o"]
298
        -- Note that that the extra bit gets inserted *before* the old suffix
299 300
        -- We assume the old suffix contains no dots, so we know where to
        -- split it
301
insertSuffixes file_name extras
302
  = [ basename <.> (extra ++ suffix) | extra <- extras ]
303
  where
304 305 306
    (basename, suffix) = case splitExtension file_name of
                         -- Drop the "." from the extension
                         (b, s) -> (b, drop 1 s)
307 308 309 310


-----------------------------------------------------------------
--
311 312
--              endMkDependHs
--      Complete the makefile, close the tmp file etc
313 314
--
-----------------------------------------------------------------
315

316
endMkDependHS :: DynFlags -> MkDepFiles -> IO ()
317

318
endMkDependHS dflags
319
   (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,
320
            mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl })
321 322 323 324 325 326 327 328
  = do
  -- write the magic marker into the tmp file
  hPutStrLn tmp_hdl depEndMarker

  case makefile_hdl of
     Nothing  -> return ()
     Just hdl -> do

329 330 331 332 333
          -- slurp the rest of the original makefile and copy it into the output
        let slurp = do
                l <- hGetLine hdl
                hPutStrLn tmp_hdl l
                slurp
334

335
        catchIO slurp
336 337 338
                (\e -> if isEOFError e then return () else ioError e)

        hClose hdl
339

340
  hClose tmp_hdl  -- make sure it's flushed
341

342
        -- Create a backup of the original makefile
343
  when (isJust makefile_hdl)
344 345
       (SysTools.copy dflags ("Backing up " ++ makefile)
          makefile (makefile++".bak"))
346

347
        -- Copy the new makefile in place
348
  SysTools.copy dflags "Installing new makefile" tmp_file makefile
349 350


351
-----------------------------------------------------------------
352
--              Module cycles
353 354
-----------------------------------------------------------------

355 356
dumpModCycles :: DynFlags -> ModuleGraph -> IO ()
dumpModCycles dflags module_graph
357
  | not (dopt Opt_D_dump_mod_cycles dflags)
358 359 360
  = return ()

  | null cycles
361
  = putMsg dflags (text "No module cycles")
362 363

  | otherwise
364
  = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles)
365 366 367
  where

    cycles :: [[ModSummary]]
368 369
    cycles =
      [ c | CyclicSCC c <- GHC.topSortModuleGraph True module_graph Nothing ]
370

371
    pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------"))
372
                        $$ pprCycle c $$ blankLine
373
                     | (n,c) <- [1..] `zip` cycles ]
374 375 376 377 378

pprCycle :: [ModSummary] -> SDoc
-- Print a cycle, but show only the imports within the cycle
pprCycle summaries = pp_group (CyclicSCC summaries)
  where
379
    cycle_mods :: [ModuleName]  -- The modules in this cycle
380 381 382
    cycle_mods = map (moduleName . ms_mod) summaries

    pp_group (AcyclicSCC ms) = pp_ms ms
383 384 385 386 387 388 389 390
    pp_group (CyclicSCC mss)
        = ASSERT( not (null boot_only) )
                -- The boot-only list must be non-empty, else there would
                -- be an infinite chain of non-boot imoprts, and we've
                -- already checked for that in processModDeps
          pp_ms loop_breaker $$ vcat (map pp_group groups)
        where
          (boot_only, others) = partition is_boot_only mss
391
          is_boot_only ms = not (any in_group (map snd (ms_imps ms)))
392 393 394 395 396
          in_group (L _ m) = m `elem` group_mods
          group_mods = map (moduleName . ms_mod) mss

          loop_breaker = head boot_only
          all_others   = tail boot_only ++ others
397 398
          groups =
            GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing
399 400

    pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
401
                       <+> (pp_imps empty (map snd (ms_imps summary)) $$
402
                            pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))
403 404
        where
          mod_str = moduleNameString (moduleName (ms_mod summary))
405 406

    pp_imps :: SDoc -> [Located ModuleName] -> SDoc
407
    pp_imps _    [] = empty
408 409 410
    pp_imps what lms
        = case [m | L _ m <- lms, m `elem` cycle_mods] of
            [] -> empty
411
            ms -> what <+> text "imports" <+>
412
                                pprWithCommas ppr ms
413

414 415
-----------------------------------------------------------------
--
416
--              Flags
417 418 419
--
-----------------------------------------------------------------

420
depStartMarker, depEndMarker :: String
421 422
depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
423