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