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