From f57e800a1d1a8e9f2bed34428f7f58a375f178fb Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Sun, 11 Jul 2021 17:56:34 +0200 Subject: WIP splitting of Target module and towards parallel builds --- Coolbal/Target/Class.hs | 47 +++++++ Coolbal/Target/Executable.hs | 254 +++++++++++++++++++++++++++++++------- Coolbal/Target/Executable/Make.hs | 48 +++++++ Coolbal/Target/Utils.hs | 72 +++++++++++ 4 files changed, 379 insertions(+), 42 deletions(-) create mode 100644 Coolbal/Target/Class.hs create mode 100644 Coolbal/Target/Executable/Make.hs create mode 100644 Coolbal/Target/Utils.hs (limited to 'Coolbal/Target') diff --git a/Coolbal/Target/Class.hs b/Coolbal/Target/Class.hs new file mode 100644 index 0000000..ea966d6 --- /dev/null +++ b/Coolbal/Target/Class.hs @@ -0,0 +1,47 @@ +module Coolbal.Target.Class where + +import Coolbal.Options (Flags) + + +class IsTarget a where + -- | The name of the target. + targetName :: a -> String + + -- | The cabal-style prefix indicating the kind of target (e.g. 'exe' for an executable target). + targetPrefix :: a -> String + + -- | The name of the target, qualified with a cabal-style prefix indicating the kind of target. + targetNameQualified :: a -> String + targetNameQualified tg = buildQualifiedName (targetPrefix tg) (targetName tg) + + -- | The name of the target, qualified with a cabal-style prefix indicating + -- the kind of target, except that the ':' is rendered as a '-'. + targetNameQualifiedFilename :: a -> FilePath + targetNameQualifiedFilename = qualifiedToQualifiedFilename . targetNameQualified + + -- | Check whether the target must be recompiled due to changes on disk. + -- Argument is the root directory of the project. + targetCheckOld :: FilePath -> a -> IO Bool + + -- | Recompile the target. + targetBuild :: Flags -> a -> IO () + + -- | If the target is an executable target, return an IO action that runs + -- the executable with the specified arguments. The 'FilePath' is the root + -- directory of the project. + targetExecute :: Flags -> a -> Maybe ([String] -> IO ()) + + -- | Remove the build artifacts for this target. + targetRemoveBuildArtifacts :: FilePath -> a -> IO () + +data RestoreEnv = RestoreEnv + { reProjDir :: FilePath } + +qualifiedToQualifiedFilename :: String -> FilePath +qualifiedToQualifiedFilename qual = + case break (== ':') qual of + (pre, ':' : post) -> pre ++ '-' : post + _ -> error "qualifiedToQualifiedFilename: unexpected form of targetNameQualified" + +buildQualifiedName :: String -> String -> String +buildQualifiedName prefix name = prefix ++ ":" ++ name diff --git a/Coolbal/Target/Executable.hs b/Coolbal/Target/Executable.hs index 725b057..0f856c6 100644 --- a/Coolbal/Target/Executable.hs +++ b/Coolbal/Target/Executable.hs @@ -1,42 +1,212 @@ -module Coolbal.Target.Executable (makeExeTarget) where - -import Data.List (find) -import Distribution.Compiler (perCompilerFlavorToList, CompilerFlavor(GHC)) -import qualified Distribution.ModuleName as Module -import Distribution.Types.BuildInfo (BuildInfo(..)) -import Distribution.Types.Executable (Executable(..)) -import Distribution.Types.ExecutableScope (ExecutableScope(ExecutablePublic)) -import Distribution.Types.UnqualComponentName (unUnqualComponentName) -import Language.Haskell.Extension (knownLanguages) - -import Coolbal.CabalPlan -import Coolbal.Directory -import Coolbal.Target - - -makeExeTarget :: Executable -> CabalPlan -> Maybe ExeTarget -makeExeTarget exe plan - | exeScope exe == ExecutablePublic - , let bi = buildInfo exe - , buildable bi - , all (null . ($ bi)) [asmSources, cmmSources, cSources, cxxSources, jsSources] - , all (null . ($ bi)) [virtualModules, autogenModules] - , null (defaultExtensions bi) - , all (null . ($ bi)) [extraLibs, extraBundledLibs] - , let name = unUnqualComponentName (exeName exe) - , Just planpkg@Configured{} <- find ((== name) . ppName) (planPackages plan) - , Just language <- defaultLanguage bi - , True <- language `elem` knownLanguages - , Just flags <- lookup GHC (perCompilerFlavorToList (options bi)) - , Just deps <- ppDepends planpkg - = Just (ExeTarget - { exeTargetName = unUnqualComponentName (exeName exe) - , exeTargetPkgDbDir = currentHomeDirectory ++ "/.cabal/store/" ++ planCompiler plan ++ "/package.db" - , exeTargetDeps = deps - , exeTargetLanguage = show language - , exeTargetMain = modulePath exe - , exeTargetSrcDirs = hsSourceDirs bi - , exeTargetModules = map Module.components (otherModules bi) - , exeTargetFlags = flags - }) - | otherwise = Nothing +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module Coolbal.Target.Executable where + +import Control.DeepSeq (deepseq) +import Data.Binary +import Data.List (intercalate) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import GHC.Generics (Generic) +import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) +import System.Exit (die, exitWith) +import System.FilePath ((), makeRelative) +import System.IO.Error (catchIOError) +import System.IO.Temp + +import Coolbal.Options (Flags) +import Coolbal.DataVersionTag +import Coolbal.EnvBinary +import Coolbal.Log +import Coolbal.MakeParse +import Coolbal.Process +import Coolbal.Target.Class +import Coolbal.Target.Utils + + +data ExeTarget = ExeTarget + { etName :: String + -- ^ Target name, and name of output executable file + , etPkgDbDir :: FilePath + -- ^ Absolute path to the package.db directory + , etDeps :: [String] + -- ^ Package identifiers of dependencies (for -package-id flags) + , etLanguage :: String + -- ^ Haskell language (e.g. Haskell2010) + , etMain :: FilePath + -- ^ Main file + , etSrcDirs :: [FilePath] + -- ^ Source directories + , etFlags :: [String] + -- ^ User-specified compiler flags + , etModGraph :: Map [String] [[String]] + -- ^ Dependency graph of other modules in the target + + , etModules :: [[String]] + -- ^ List of other modules in the target + , etProjDir :: FilePath + -- ^ Project root directory (absolute path) + , etBuildDir :: FilePath + -- ^ Build directory (absolute path) + , etBinDir :: FilePath + -- ^ Binary target directory (absolute path) + , etBinFile :: FilePath + -- ^ Target executable file path (absolute path) + , etBaseFlags :: [String] + -- ^ Base flags for GHC (excluding --make, module/file list, -c/-o) + } + deriving (Show) + +data ExeTargetStore' mods = ExeTargetStore + { _etsVersionTag :: DataVersionTag 1 + , etsName :: String + -- ^ Target name, and name of output executable file + , etsPkgDbDir :: FilePath + -- ^ Absolute path to the package.db directory + , etsDeps :: [String] + -- ^ Package identifiers of dependencies (for -package-id flags) + , etsLanguage :: String + -- ^ Haskell language (e.g. Haskell2010) + , etsMain :: FilePath + -- ^ Main file + , etsSrcDirs :: [FilePath] + -- ^ Source directories + , etsFlags :: [String] + -- ^ User-specified compiler flags + , etsModules :: mods + -- ^ Dependency graph of other modules in the target + } + +type ExeTargetStorePre = ExeTargetStore' [[String]] +type ExeTargetStore = ExeTargetStore' (Map [String] [[String]]) + +deriving instance Generic ExeTargetStore + +instance Binary ExeTargetStore + +instance EnvBinary RestoreEnv ExeTarget where + envget renv = elaborateExeTarget renv <$> get + envput = put . unelabExeTarget + +elaborateExeTargetWithEBS :: ExeBuildSetup -> ExeTargetStore -> ExeTarget +elaborateExeTargetWithEBS ebs tg = ExeTarget + { etName = etsName tg + , etPkgDbDir = etsPkgDbDir tg + , etDeps = etsDeps tg + , etLanguage = etsLanguage tg + , etMain = etsMain tg + , etSrcDirs = etsSrcDirs tg + , etFlags = etsFlags tg + , etModGraph = etsModules tg + + , etModules = Map.keys (etsModules tg) + , etProjDir = ebsProjDir ebs + , etBuildDir = ebsBuildDir ebs + , etBinDir = ebsBinDir ebs + , etBinFile = ebsBinFile ebs + , etBaseFlags = ebsBaseFlags ebs + } + +elaborateExeTarget :: RestoreEnv -> ExeTargetStore -> ExeTarget +elaborateExeTarget RestoreEnv{reProjDir=projdir} tg = + let ebs = exeBuildSetup projdir (tg { etsModules = Map.keys (etsModules tg) }) + in elaborateExeTargetWithEBS ebs tg + +unelabExeTarget :: ExeTarget -> ExeTargetStore +unelabExeTarget tg = ExeTargetStore + { _etsVersionTag = DataVersionTag + , etsName = etName tg + , etsPkgDbDir = etPkgDbDir tg + , etsDeps = etDeps tg + , etsLanguage = etLanguage tg + , etsMain = etMain tg + , etsSrcDirs = etSrcDirs tg + , etsFlags = etFlags tg + , etsModules = etModGraph tg + } + +instance IsTarget ExeTarget where + targetName = etName + targetPrefix _ = "exe" + + targetCheckOld projdir tg = do + mbinTm <- maybeModificationTime (projdir "dist-coolbal/bin" escapeFileName (etName tg)) + case mbinTm of + Just binTm -> do + anyNewerThan binTm (findFile' (etSrcDirs tg) (etMain tg) + : [findSourceFile' (etSrcDirs tg) m | m <- etModules tg]) + Nothing -> + return True + + targetBuild flags tg = do + createDirectoryIfMissing True (etBinDir tg) + -- To build only a single module instead of the whole executable: remove etMain and add only the right module of etModules; add -c; remove -o. + runCommand flags "ghc" (concat + [["--make"] + ,etBaseFlags tg + ,[etMain tg] + ,map (intercalate ".") (etModules tg) + ,["-o", etBinFile tg]]) + >>= checkExitCode + + targetExecute flags tg = Just $ \args -> do + let filename = escapeFileName (etName tg) + runCommand flags (etProjDir tg "dist-coolbal/bin" filename) args + >>= exitWith + + targetRemoveBuildArtifacts projdir tg = + removeDirectoryRecursive + (projdir "dist-coolbal/build" + escapeFileName (targetNameQualifiedFilename tg)) + `catchIOError` (\_ -> return ()) + +data ExeBuildSetup = ExeBuildSetup + { ebsProjDir :: FilePath + , ebsBuildDir :: FilePath + , ebsBinDir :: FilePath + , ebsBinFile :: FilePath + , ebsBaseFlags :: [String] + } + +exeBuildSetup :: FilePath -> ExeTargetStorePre -> ExeBuildSetup +exeBuildSetup projdir tg = + let buildDir = projdir "dist-coolbal/build" + escapeFileName (buildQualifiedName "exe" (etsName tg)) + binDir = projdir "dist-coolbal/bin" + in ExeBuildSetup + { ebsProjDir = projdir + , ebsBuildDir = buildDir + , ebsBinDir = binDir + , ebsBinFile = binDir escapeFileName (etsName tg) + , ebsBaseFlags = concat + [["-static"] + ,concat [[flag, buildDir] + | flag <- ["-outputdir", "-odir", "-hidir", "-stubdir"]] + ,["-i" ++ dir | dir <- etsSrcDirs tg] + ,["-hide-all-packages", "-Wmissing-home-modules", "-no-user-package-db"] + ,["-package-db", etsPkgDbDir tg] + ,concat [["-package-id", dep] | dep <- etsDeps tg] + ,["-X" ++ etsLanguage tg] + ,etsFlags tg] + } + +exeDepGraph :: Flags -> ExeTargetStorePre -> ExeBuildSetup -> IO (Map [String] [[String]]) +exeDepGraph flags tg ebs = do + output <- withSystemTempDirectory "coolbal-make" $ \tmpdir -> do + let fname = tmpdir "Makefile" + runCommand flags "ghc" (concat + [ebsBaseFlags ebs + ,[etsMain tg] + ,map (intercalate ".") (etsModules tg) + ,["-M", "-dep-suffix", "", "-dep-makefile", fname]]) + >>= checkExitCode + output <- readFile fname + output `deepseq` return output + case parseGHCmake (ebsProjDir ebs) (makeRelative (ebsProjDir ebs) (ebsBuildDir ebs)) output of + Left err -> die err + Right m -> logVerbose flags "depgraph:graph" (show m) >> return m diff --git a/Coolbal/Target/Executable/Make.hs b/Coolbal/Target/Executable/Make.hs new file mode 100644 index 0000000..5bbb80e --- /dev/null +++ b/Coolbal/Target/Executable/Make.hs @@ -0,0 +1,48 @@ +module Coolbal.Target.Executable.Make (makeExeTarget) where + +import Data.List (find) +import Distribution.Compiler (perCompilerFlavorToList, CompilerFlavor(GHC)) +import qualified Distribution.ModuleName as Module +import Distribution.Types.BuildInfo (BuildInfo(..)) +import Distribution.Types.Executable (Executable(..)) +import Distribution.Types.ExecutableScope (ExecutableScope(ExecutablePublic)) +import Distribution.Types.UnqualComponentName (unUnqualComponentName) +import Language.Haskell.Extension (knownLanguages) + +import Coolbal.CabalPlan +import Coolbal.DataVersionTag +import Coolbal.Directory +import Coolbal.Options (Flags) +import Coolbal.Target.Executable + + +makeExeTarget :: Flags -> FilePath -> Executable -> CabalPlan -> IO (Maybe ExeTarget) +makeExeTarget flags projdir exe plan + | exeScope exe == ExecutablePublic + , let bi = buildInfo exe + , buildable bi + , all (null . ($ bi)) [asmSources, cmmSources, cSources, cxxSources, jsSources] + , all (null . ($ bi)) [virtualModules, autogenModules] + , null (defaultExtensions bi) + , all (null . ($ bi)) [extraLibs, extraBundledLibs] + , let name = unUnqualComponentName (exeName exe) + , Just planpkg <- find ((== name) . ppName) (planPackages plan) + , Just language <- defaultLanguage bi + , True <- language `elem` knownLanguages + , Just ghcFlags <- lookup GHC (perCompilerFlavorToList (options bi)) + , Just deps <- ppDepends planpkg + = do let ets = ExeTargetStore + { _etsVersionTag = DataVersionTag + , etsName = unUnqualComponentName (exeName exe) + , etsPkgDbDir = currentHomeDirectory ++ "/.cabal/store/" ++ planCompiler plan ++ "/package.db" + , etsDeps = deps + , etsLanguage = show language + , etsMain = modulePath exe + , etsSrcDirs = hsSourceDirs bi + , etsModules = map Module.components (otherModules bi) + , etsFlags = ghcFlags + } + ebs = exeBuildSetup projdir ets + depgraph <- exeDepGraph flags ets ebs + return (Just (elaborateExeTargetWithEBS ebs (ets { etsModules = depgraph }))) + | otherwise = return Nothing diff --git a/Coolbal/Target/Utils.hs b/Coolbal/Target/Utils.hs new file mode 100644 index 0000000..432a8a8 --- /dev/null +++ b/Coolbal/Target/Utils.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE LambdaCase #-} +module Coolbal.Target.Utils where + +import Data.Char (ord) +import Data.List (intercalate) +import Data.Time.Clock (UTCTime) +import Numeric (showHex) +import System.Directory (doesFileExist, getModificationTime) +import System.Exit (ExitCode(..), die, exitWith) +import System.FilePath (()) +import System.IO.Error (catchIOError) + +import Coolbal.Util + + +checkExitCode :: ExitCode -> IO () +checkExitCode ExitSuccess = return () +checkExitCode c@(ExitFailure _) = exitWith c + +escapeFileName :: String -> FilePath +escapeFileName = + -- NTFS/POSIX not allows: 0x00-0x1F 0x7F- : / " * < > ? \ | + -- We use ! as an escape character, and hence disallow that too. + genericEscapeString + (\c -> let n = ord c + in n <= 0x1F || n >= 0x7F || c `elem` ":/\"*<>?\\|!") + (\c -> case (c, ord c) of + ('!', _) -> "!!" + (_, n) | n <= 0xFF -> '!' : leftPad 2 '0' (showHex n "") + | n <= 0xFFFF -> '!' : 'u' : leftPad 4 '0' (showHex n "") + | n <= 0xFFFFFF -> '!' : 'U' : leftPad 6 '0' (showHex n "") + | otherwise -> error "Super-high unicode?") + where + leftPad n c s = replicate (max 0 (n - length s)) c ++ s + +maybeModificationTime' :: FilePath -> IO UTCTime +maybeModificationTime' path = maybeModificationTime path >>= \case + Just tm -> return tm + Nothing -> die ("File not found: '" ++ path ++ "'") + +maybeModificationTime :: FilePath -> IO (Maybe UTCTime) +maybeModificationTime path = + catchIOError (Just <$> getModificationTime path) (\_ -> return Nothing) + +findSourceFile' :: [FilePath] -> [String] -> IO FilePath +findSourceFile' ds m = findSourceFile ds m >>= \case + Just fp -> return fp + Nothing -> die ("Module not found in source directories: " ++ intercalate "." m) + +findSourceFile :: [FilePath] -> [String] -> IO (Maybe FilePath) +findSourceFile dirs modname = findFile dirs (foldr () "" modname ++ ".hs") + +findFile' :: [FilePath] -> FilePath -> IO FilePath +findFile' ds fname = findFile ds fname >>= \case + Just fp -> return fp + Nothing -> die ("File not found in source directories: '" ++ fname ++ "'") + +findFile :: [FilePath] -> FilePath -> IO (Maybe FilePath) +findFile [] _ = return Nothing +findFile (dir:ds) fname = do + ok <- doesFileExist (dir fname) + if ok then return (Just (dir fname)) + else findFile ds fname + +anyNewerThan :: UTCTime -> [IO FilePath] -> IO Bool +anyNewerThan _ [] = return False +anyNewerThan reftm (fp:fps) = do + fp' <- fp + tm <- maybeModificationTime' fp' + if tm > reftm + then return True + else anyNewerThan reftm fps -- cgit v1.2.3-70-g09d2