ghc-lib-0.20200401: compiler/GHC/Driver/MakeFile.hs
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
--
-- Makefile Dependency Generation
--
-- (c) The University of Glasgow 2005
--
-----------------------------------------------------------------------------
module GHC.Driver.MakeFile
( doMkDependHS
)
where
#include "HsVersions.h"
import GhcPrelude
import qualified GHC
import GHC.Driver.Monad
import GHC.Driver.Session
import GHC.Driver.Ways
import Util
import GHC.Driver.Types
import qualified SysTools
import GHC.Types.Module
import Digraph ( SCC(..) )
import GHC.Driver.Finder
import Outputable
import Panic
import GHC.Types.SrcLoc
import Data.List
import FastString
import FileCleanup
import Exception
import ErrUtils
import System.Directory
import System.FilePath
import System.IO
import System.IO.Error ( isEOFError )
import Control.Monad ( when )
import Data.Maybe ( isJust )
import Data.IORef
import qualified Data.Set as Set
-----------------------------------------------------------------
--
-- The main function
--
-----------------------------------------------------------------
doMkDependHS :: GhcMonad m => [FilePath] -> m ()
doMkDependHS srcs = do
-- Initialisation
dflags0 <- GHC.getSessionDynFlags
-- We kludge things a bit for dependency generation. Rather than
-- generating dependencies for each way separately, we generate
-- them once and then duplicate them for each way's osuf/hisuf.
-- We therefore do the initial dependency generation with an empty
-- way and .o/.hi extensions, regardless of any flags that might
-- be specified.
let dflags = dflags0 {
ways = Set.empty,
buildTag = waysTag Set.empty,
hiSuf = "hi",
objectSuf = "o"
}
_ <- GHC.setSessionDynFlags dflags
when (null (depSuffixes dflags)) $ liftIO $
throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")
files <- liftIO $ beginMkDependHS dflags
-- Do the downsweep to find all the modules
targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs
GHC.setTargets targets
let excl_mods = depExcludeMods dflags
module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}
-- Sort into dependency order
-- There should be no cycles
let sorted = GHC.topSortModuleGraph False module_graph Nothing
-- Print out the dependencies if wanted
liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)
-- Process them one by one, dumping results into makefile
-- and complaining about cycles
hsc_env <- getSession
root <- liftIO getCurrentDirectory
mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
-- If -ddump-mod-cycles, show cycles in the module graph
liftIO $ dumpModCycles dflags module_graph
-- Tidy up
liftIO $ endMkDependHS dflags files
-- Unconditional exiting is a bad idea. If an error occurs we'll get an
--exception; if that is not caught it's fine, but at least we have a
--chance to find out exactly what went wrong. Uncomment the following
--line if you disagree.
--`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
-----------------------------------------------------------------
--
-- beginMkDependHs
-- Create a temporary file,
-- find the Makefile,
-- slurp through it, etc
--
-----------------------------------------------------------------
data MkDepFiles
= MkDep { mkd_make_file :: FilePath, -- Name of the makefile
mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile
mkd_tmp_file :: FilePath, -- Name of the temporary file
mkd_tmp_hdl :: Handle } -- Handle of the open temporary file
beginMkDependHS :: DynFlags -> IO MkDepFiles
beginMkDependHS dflags = do
-- open a new temp file in which to stuff the dependency info
-- as we go along.
tmp_file <- newTempName dflags TFL_CurrentModule "dep"
tmp_hdl <- openFile tmp_file WriteMode
-- open the makefile
let makefile = depMakefile dflags
exists <- doesFileExist makefile
mb_make_hdl <-
if not exists
then return Nothing
else do
makefile_hdl <- openFile makefile ReadMode
-- slurp through until we get the magic start string,
-- copying the contents into dep_makefile
let slurp = do
l <- hGetLine makefile_hdl
if (l == depStartMarker)
then return ()
else do hPutStrLn tmp_hdl l; slurp
-- slurp through until we get the magic end marker,
-- throwing away the contents
let chuck = do
l <- hGetLine makefile_hdl
if (l == depEndMarker)
then return ()
else chuck
catchIO slurp
(\e -> if isEOFError e then return () else ioError e)
catchIO chuck
(\e -> if isEOFError e then return () else ioError e)
return (Just makefile_hdl)
-- write the magic marker into the tmp file
hPutStrLn tmp_hdl depStartMarker
return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl})
-----------------------------------------------------------------
--
-- processDeps
--
-----------------------------------------------------------------
processDeps :: DynFlags
-> HscEnv
-> [ModuleName]
-> FilePath
-> Handle -- Write dependencies to here
-> SCC ModSummary
-> IO ()
-- Write suitable dependencies to handle
-- Always:
-- this.o : this.hs
--
-- If the dependency is on something other than a .hi file:
-- this.o this.p_o ... : dep
-- otherwise
-- this.o ... : dep.hi
-- this.p_o ... : dep.p_hi
-- ...
-- (where .o is $osuf, and the other suffixes come from
-- the cmdline -s options).
--
-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
processDeps dflags _ _ _ _ (CyclicSCC nodes)
= -- There shouldn't be any cycles; report them
throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
= do { let extra_suffixes = depSuffixes dflags
include_pkg_deps = depIncludePkgDeps dflags
src_file = msHsFilePath node
obj_file = msObjFilePath node
obj_files = insertSuffixes obj_file extra_suffixes
do_imp loc is_boot pkg_qual imp_mod
= do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod
is_boot include_pkg_deps
; case mb_hi of {
Nothing -> return () ;
Just hi_file -> do
{ let hi_files = insertSuffixes hi_file extra_suffixes
write_dep (obj,hi) = writeDependency root hdl [obj] hi
-- Add one dependency for each suffix;
-- e.g. A.o : B.hi
-- A.x_o : B.x_hi
; mapM_ write_dep (obj_files `zip` hi_files) }}}
-- Emit std dependency of the object(s) on the source file
-- Something like A.o : A.hs
; writeDependency root hdl obj_files src_file
-- Emit a dependency for each CPP import
; when (depIncludeCppDeps dflags) $ do
-- CPP deps are descovered in the module parsing phase by parsing
-- comment lines left by the preprocessor.
-- Note that GHC.parseModule may throw an exception if the module
-- fails to parse, which may not be desirable (see #16616).
{ session <- Session <$> newIORef hsc_env
; parsedMod <- reflectGhc (GHC.parseModule node) session
; mapM_ (writeDependency root hdl obj_files)
(GHC.pm_extra_src_files parsedMod)
}
-- Emit a dependency for each import
; let do_imps is_boot idecls = sequence_
[ do_imp loc is_boot mb_pkg mod
| (mb_pkg, L loc mod) <- idecls,
mod `notElem` excl_mods ]
; do_imps True (ms_srcimps node)
; do_imps False (ms_imps node)
}
findDependency :: HscEnv
-> SrcSpan
-> Maybe FastString -- package qualifier, if any
-> ModuleName -- Imported module
-> IsBootInterface -- Source import
-> Bool -- Record dependency on package modules
-> IO (Maybe FilePath) -- Interface file file
findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
= do { -- Find the module; this will be fast because
-- we've done it once during downsweep
r <- findImportedModule hsc_env imp pkg
; case r of
Found loc _
-- Home package: just depend on the .hi or hi-boot file
| isJust (ml_hs_file loc) || include_pkg_deps
-> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
-- Not in this package: we don't need a dependency
| otherwise
-> return Nothing
fail ->
let dflags = hsc_dflags hsc_env
in throwOneError $ mkPlainErrMsg dflags srcloc $
cannotFindModule dflags imp fail
}
-----------------------------
writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
-- t1 t2 : dep
writeDependency root hdl targets dep
= do let -- We need to avoid making deps on
-- c:/foo/...
-- on cygwin as make gets confused by the :
-- Making relative deps avoids some instances of this.
dep' = makeRelative root dep
forOutput = escapeSpaces . reslash Forwards . normalise
output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
hPutStrLn hdl output
-----------------------------
insertSuffixes
:: FilePath -- Original filename; e.g. "foo.o"
-> [String] -- Suffix prefixes e.g. ["x_", "y_"]
-> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"]
-- Note that that the extra bit gets inserted *before* the old suffix
-- We assume the old suffix contains no dots, so we know where to
-- split it
insertSuffixes file_name extras
= [ basename <.> (extra ++ suffix) | extra <- extras ]
where
(basename, suffix) = case splitExtension file_name of
-- Drop the "." from the extension
(b, s) -> (b, drop 1 s)
-----------------------------------------------------------------
--
-- endMkDependHs
-- Complete the makefile, close the tmp file etc
--
-----------------------------------------------------------------
endMkDependHS :: DynFlags -> MkDepFiles -> IO ()
endMkDependHS dflags
(MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl,
mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl })
= do
-- write the magic marker into the tmp file
hPutStrLn tmp_hdl depEndMarker
case makefile_hdl of
Nothing -> return ()
Just hdl -> do
-- slurp the rest of the original makefile and copy it into the output
let slurp = do
l <- hGetLine hdl
hPutStrLn tmp_hdl l
slurp
catchIO slurp
(\e -> if isEOFError e then return () else ioError e)
hClose hdl
hClose tmp_hdl -- make sure it's flushed
-- Create a backup of the original makefile
when (isJust makefile_hdl)
(SysTools.copy dflags ("Backing up " ++ makefile)
makefile (makefile++".bak"))
-- Copy the new makefile in place
SysTools.copy dflags "Installing new makefile" tmp_file makefile
-----------------------------------------------------------------
-- Module cycles
-----------------------------------------------------------------
dumpModCycles :: DynFlags -> ModuleGraph -> IO ()
dumpModCycles dflags module_graph
| not (dopt Opt_D_dump_mod_cycles dflags)
= return ()
| null cycles
= putMsg dflags (text "No module cycles")
| otherwise
= putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles)
where
cycles :: [[ModSummary]]
cycles =
[ c | CyclicSCC c <- GHC.topSortModuleGraph True module_graph Nothing ]
pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------"))
$$ pprCycle c $$ blankLine
| (n,c) <- [1..] `zip` cycles ]
pprCycle :: [ModSummary] -> SDoc
-- Print a cycle, but show only the imports within the cycle
pprCycle summaries = pp_group (CyclicSCC summaries)
where
cycle_mods :: [ModuleName] -- The modules in this cycle
cycle_mods = map (moduleName . ms_mod) summaries
pp_group (AcyclicSCC ms) = pp_ms ms
pp_group (CyclicSCC mss)
= ASSERT( not (null boot_only) )
-- The boot-only list must be non-empty, else there would
-- be an infinite chain of non-boot imports, and we've
-- already checked for that in processModDeps
pp_ms loop_breaker $$ vcat (map pp_group groups)
where
(boot_only, others) = partition is_boot_only mss
is_boot_only ms = not (any in_group (map snd (ms_imps ms)))
in_group (L _ m) = m `elem` group_mods
group_mods = map (moduleName . ms_mod) mss
loop_breaker = head boot_only
all_others = tail boot_only ++ others
groups =
GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing
pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
<+> (pp_imps empty (map snd (ms_imps summary)) $$
pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))
where
mod_str = moduleNameString (moduleName (ms_mod summary))
pp_imps :: SDoc -> [Located ModuleName] -> SDoc
pp_imps _ [] = empty
pp_imps what lms
= case [m | L _ m <- lms, m `elem` cycle_mods] of
[] -> empty
ms -> what <+> text "imports" <+>
pprWithCommas ppr ms
-----------------------------------------------------------------
--
-- Flags
--
-----------------------------------------------------------------
depStartMarker, depEndMarker :: String
depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"