module GHC.Driver.MakeFile
( doMkDependHS
)
where
import GHC.Prelude
import qualified GHC
import GHC.Driver.Monad
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Utils.Misc
import GHC.Driver.Env
import GHC.Driver.Errors.Types
import qualified GHC.SysTools as SysTools
import GHC.Data.Graph.Directed ( SCC(..) )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.PkgQual
import Data.List (partition)
import GHC.Utils.TmpFs
import GHC.Iface.Load (cannotFindModule)
import GHC.Unit.Module
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Graph
import GHC.Unit.Finder
import GHC.Utils.Exception
import GHC.Utils.Error
import GHC.Utils.Logger
import System.Directory
import System.FilePath
import System.IO
import System.IO.Error ( isEOFError )
import Control.Monad ( when, forM_ )
import Data.Maybe ( isJust )
import Data.IORef
import qualified Data.Set as Set
doMkDependHS :: GhcMonad m => [FilePath] -> m ()
doMkDependHS srcs = do
logger <- getLogger
dflags0 <- GHC.getSessionDynFlags
let dflags1 = dflags0
{ targetWays_ = Set.empty
, hiSuf_ = "hi"
, objectSuf_ = "o"
}
GHC.setSessionDynFlags dflags1
let dflags = if null (depSuffixes dflags1)
then dflags1 { depSuffixes = [""] }
else dflags1
tmpfs <- hsc_tmpfs <$> getSession
files <- liftIO $ beginMkDependHS logger tmpfs dflags
targets <- mapM (\s -> GHC.guessTarget s Nothing Nothing) srcs
GHC.setTargets targets
let excl_mods = depExcludeMods dflags
module_graph <- GHC.depanal excl_mods True
let sorted = GHC.topSortModuleGraph False module_graph Nothing
liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted)
hsc_env <- getSession
root <- liftIO getCurrentDirectory
mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
liftIO $ dumpModCycles logger module_graph
liftIO $ endMkDependHS logger files
data MkDepFiles
= MkDep { mkd_make_file :: FilePath,
mkd_make_hdl :: Maybe Handle,
mkd_tmp_file :: FilePath,
mkd_tmp_hdl :: Handle }
beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles
beginMkDependHS logger tmpfs dflags = do
tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep"
tmp_hdl <- openFile tmp_file WriteMode
let makefile = depMakefile dflags
exists <- doesFileExist makefile
mb_make_hdl <-
if not exists
then return Nothing
else do
makefile_hdl <- openFile makefile ReadMode
let slurp = do
l <- hGetLine makefile_hdl
if (l == depStartMarker)
then return ()
else do hPutStrLn tmp_hdl l; slurp
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)
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 :: DynFlags
-> HscEnv
-> [ModuleName]
-> FilePath
-> Handle
-> SCC ModuleGraphNode
-> IO ()
processDeps dflags _ _ _ _ (CyclicSCC nodes)
=
throwGhcExceptionIO $ ProgramError $
showSDoc dflags $ GHC.cyclicModuleErr nodes
processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))
=
throwGhcExceptionIO $ ProgramError $
showSDoc dflags $
vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"
, nest 2 $ ppr node ]
processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()
processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ 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
; mapM_ write_dep (obj_files `zip` hi_files) }}}
; writeDependency root hdl obj_files src_file
; when (isBootSummary node == IsBoot) $ do
let hi_boot = msHiFilePath node
let obj = removeBootSuffix (msObjFilePath node)
forM_ extra_suffixes $ \suff -> do
let way_obj = insertSuffixes obj [suff]
let way_hi_boot = insertSuffixes hi_boot [suff]
mapM_ (writeDependency root hdl way_obj) way_hi_boot
; when (depIncludeCppDeps dflags) $ do
{ session <- Session <$> newIORef hsc_env
; parsedMod <- reflectGhc (GHC.parseModule node) session
; mapM_ (writeDependency root hdl obj_files)
(GHC.pm_extra_src_files parsedMod)
}
; 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 IsBoot (ms_srcimps node)
; do_imps NotBoot (ms_imps node)
}
findDependency :: HscEnv
-> SrcSpan
-> PkgQual
-> ModuleName
-> IsBootInterface
-> Bool
-> IO (Maybe FilePath)
findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
r <- findImportedModule hsc_env imp pkg
case r of
Found loc _
| isJust (ml_hs_file loc) || include_pkg_deps
-> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
| otherwise
-> return Nothing
fail ->
throwOneError $
mkPlainErrorMsgEnvelope srcloc $
GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $
cannotFindModule hsc_env imp fail
writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
writeDependency root hdl targets dep
= do let
dep' = makeRelative root dep
forOutput = escapeSpaces . reslash Forwards . normalise
output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
hPutStrLn hdl output
insertSuffixes
:: FilePath
-> [String]
-> [FilePath]
insertSuffixes file_name extras
= [ basename <.> (extra ++ suffix) | extra <- extras ]
where
(basename, suffix) = case splitExtension file_name of
(b, s) -> (b, drop 1 s)
endMkDependHS :: Logger -> MkDepFiles -> IO ()
endMkDependHS logger
(MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl,
mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl })
= do
hPutStrLn tmp_hdl depEndMarker
case makefile_hdl of
Nothing -> return ()
Just hdl -> do
SysTools.copyHandle hdl tmp_hdl
hClose hdl
hClose tmp_hdl
when (isJust makefile_hdl) $ do
showPass logger ("Backing up " ++ makefile)
SysTools.copyFile makefile (makefile++".bak")
showPass logger "Installing new makefile"
SysTools.copyFile tmp_file makefile
dumpModCycles :: Logger -> ModuleGraph -> IO ()
dumpModCycles logger module_graph
| not (logHasDumpFlag logger Opt_D_dump_mod_cycles)
= return ()
| null cycles
= putMsg logger (text "No module cycles")
| otherwise
= putMsg logger (hang (text "Module cycles found:") 2 pp_cycles)
where
topoSort = GHC.topSortModuleGraph True module_graph Nothing
cycles :: [[ModuleGraphNode]]
cycles =
[ c | CyclicSCC c <- topoSort ]
pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> text "----------")
$$ pprCycle c $$ blankLine
| (n,c) <- [1..] `zip` cycles ]
pprCycle :: [ModuleGraphNode] -> SDoc
pprCycle summaries = pp_group (CyclicSCC summaries)
where
cycle_mods :: [ModuleName]
cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries]
pp_group :: SCC ModuleGraphNode -> SDoc
pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms
pp_group (AcyclicSCC _) = empty
pp_group (CyclicSCC mss)
= assert (not (null boot_only)) $
pp_ms loop_breaker $$ vcat (map pp_group groups)
where
(boot_only, others) = partition is_boot_only mss
is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms)))
is_boot_only _ = False
in_group (L _ m) = m `elem` group_mods
group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss]
loop_breaker = head ([ms | ModuleNode _ ms <- 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
depStartMarker, depEndMarker :: String
depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"