compiler/main/DriverMkDepend.hs

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