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