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 HsSyn            ( ImportDecl(..) )
  21 import PrelNames
  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         ; when (dopt Opt_ImplicitPrelude (ms_hspp_opts node)) $
 223             do_imp noSrcSpan False Nothing pRELUDE_NAME
 224         }
 225
 226
 227 findDependency  :: HscEnv
 228                 -> SrcSpan
 229                 -> Maybe FastString     -- package qualifier, if any
 230                 -> ModuleName           -- Imported module
 231                 -> IsBootInterface      -- Source import
 232                 -> Bool                 -- Record dependency on package modules
 233                 -> IO (Maybe FilePath)  -- Interface file file
 234 findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
 235   = do  {       -- Find the module; this will be fast because
 236                 -- we've done it once during downsweep
 237           r <- findImportedModule hsc_env imp pkg
 238         ; case r of
 239             Found loc _
 240                 -- Home package: just depend on the .hi or hi-boot file
 241                 | isJust (ml_hs_file loc) || include_pkg_deps
 242                 -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
 243
 244                 -- Not in this package: we don't need a dependency
 245                 | otherwise
 246                 -> return Nothing
 247
 248             fail -> throwOneError $ mkPlainErrMsg srcloc $
 249                         cannotFindModule (hsc_dflags hsc_env) imp fail
 250         }
 251
 252 -----------------------------
 253 writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
 254 -- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
 255 --      t1 t2 : dep
 256 writeDependency root hdl targets dep
 257   = do let -- We need to avoid making deps on
 258            --     c:/foo/...
 259            -- on cygwin as make gets confused by the :
 260            -- Making relative deps avoids some instances of this.
 261            dep' = makeRelative root dep
 262            forOutput = escapeSpaces . reslash Forwards . normalise
 263            output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
 264        hPutStrLn hdl output
 265
 266 -----------------------------
 267 insertSuffixes
 268         :: FilePath     -- Original filename;   e.g. "foo.o"
 269         -> [String]     -- Extra suffices       e.g. ["x","y"]
 270         -> [FilePath]   -- Zapped filenames     e.g. ["foo.o", "foo.x_o", "foo.y_o"]
 271         -- Note that that the extra bit gets inserted *before* the old suffix
 272         -- We assume the old suffix contains no dots, so we can strip it with removeSuffix
 273
 274         -- NOTE: we used to have this comment
 275                 -- In order to construct hi files with alternate suffixes, we
 276                 -- now have to find the "basename" of the hi file.  This is
 277                 -- difficult because we can't just split the hi filename
 278                 -- at the last dot - the hisuf might have dots in it.  So we
 279                 -- check whether the hi filename ends in hisuf, and if it does,
 280                 -- we strip off hisuf, otherwise we strip everything after the
 281                 -- last dot.
 282         -- But I'm not sure we care about hisufs with dots in them.
 283         -- Lots of other things will break first!
 284
 285 insertSuffixes file_name extras
 286   = file_name : [ basename <.> (extra ++ "_" ++ suffix) | extra <- extras ]
 287   where
 288     (basename, suffix) = case splitExtension file_name of
 289                          -- Drop the "." from the extension
 290                          (b, s) -> (b, drop 1 s)
 291
 292
 293 -----------------------------------------------------------------
 294 --
 295 --              endMkDependHs
 296 --      Complete the makefile, close the tmp file etc
 297 --
 298 -----------------------------------------------------------------
 299
 300 endMkDependHS :: DynFlags -> MkDepFiles -> IO ()
 301
 302 endMkDependHS dflags
 303    (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,
 304             mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl })
 305   = do
 306   -- write the magic marker into the tmp file
 307   hPutStrLn tmp_hdl depEndMarker
 308
 309   case makefile_hdl of
 310      Nothing  -> return ()
 311      Just hdl -> do
 312
 313           -- slurp the rest of the original makefile and copy it into the output
 314         let slurp = do
 315                 l <- hGetLine hdl
 316                 hPutStrLn tmp_hdl l
 317                 slurp
 318
 319         catchIO slurp
 320                 (\e -> if isEOFError e then return () else ioError e)
 321
 322         hClose hdl
 323
 324   hClose tmp_hdl  -- make sure it's flushed
 325
 326         -- Create a backup of the original makefile
 327   when (isJust makefile_hdl)
 328        (SysTools.copy dflags ("Backing up " ++ makefile)
 329           makefile (makefile++".bak"))
 330
 331         -- Copy the new makefile in place
 332   SysTools.copy dflags "Installing new makefile" tmp_file makefile
 333
 334
 335 -----------------------------------------------------------------
 336 --              Module cycles
 337 -----------------------------------------------------------------
 338
 339 dumpModCycles :: DynFlags -> [ModSummary] -> IO ()
 340 dumpModCycles dflags mod_summaries
 341   | not (dopt Opt_D_dump_mod_cycles dflags)
 342   = return ()
 343
 344   | null cycles
 345   = putMsg dflags (ptext (sLit "No module cycles"))
 346
 347   | otherwise
 348   = putMsg dflags (hang (ptext (sLit "Module cycles found:")) 2 pp_cycles)
 349   where
 350
 351     cycles :: [[ModSummary]]
 352     cycles = [ c | CyclicSCC c <- GHC.topSortModuleGraph True mod_summaries Nothing ]
 353
 354     pp_cycles = vcat [ (ptext (sLit "---------- Cycle") <+> int n <+> ptext (sLit "----------"))
 355                         $$ pprCycle c $$ text ""
 356                      | (n,c) <- [1..] `zip` cycles ]
 357
 358 pprCycle :: [ModSummary] -> SDoc
 359 -- Print a cycle, but show only the imports within the cycle
 360 pprCycle summaries = pp_group (CyclicSCC summaries)
 361   where
 362     cycle_mods :: [ModuleName]  -- The modules in this cycle
 363     cycle_mods = map (moduleName . ms_mod) summaries
 364
 365     pp_group (AcyclicSCC ms) = pp_ms ms
 366     pp_group (CyclicSCC mss)
 367         = ASSERT( not (null boot_only) )
 368                 -- The boot-only list must be non-empty, else there would
 369                 -- be an infinite chain of non-boot imoprts, and we've
 370                 -- already checked for that in processModDeps
 371           pp_ms loop_breaker $$ vcat (map pp_group groups)
 372         where
 373           (boot_only, others) = partition is_boot_only mss
 374           is_boot_only ms = not (any in_group (map (ideclName.unLoc) (ms_imps ms)))
 375           in_group (L _ m) = m `elem` group_mods
 376           group_mods = map (moduleName . ms_mod) mss
 377
 378           loop_breaker = head boot_only
 379           all_others   = tail boot_only ++ others
 380           groups = GHC.topSortModuleGraph True all_others Nothing
 381
 382     pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
 383                        <+> (pp_imps empty (map (ideclName.unLoc) (ms_imps summary)) $$
 384                             pp_imps (ptext (sLit "{-# SOURCE #-}")) (map (ideclName.unLoc) (ms_srcimps summary)))
 385         where
 386           mod_str = moduleNameString (moduleName (ms_mod summary))
 387
 388     pp_imps :: SDoc -> [Located ModuleName] -> SDoc
 389     pp_imps _    [] = empty
 390     pp_imps what lms
 391         = case [m | L _ m <- lms, m `elem` cycle_mods] of
 392             [] -> empty
 393             ms -> what <+> ptext (sLit "imports") <+>
 394                                 pprWithCommas ppr ms
 395
 396 -----------------------------------------------------------------
 397 --
 398 --              Flags
 399 --
 400 -----------------------------------------------------------------
 401
 402 depStartMarker, depEndMarker :: String
 403 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
 404 depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
 405