compiler/main/DriverMkDepend.hs

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