Skip to content
GitLab
Commit 8c3022df authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Move generators to a dedicated directory, and track their changes.

parent bdb88c61
Hide whitespace changes
Inline Side-by-side
shaking-up-ghc.cabal
View file @ 8c3022df
......@@ -42,6 +42,9 @@ executable ghc-shake
, Rules.Dependencies
, Rules.Documentation
, Rules.Generate
, Rules.Generators.ConfigHs
, Rules.Generators.GhcPkgVersionHs
, Rules.Generators.PlatformH
, Rules.Library
, Rules.Oracles
, Rules.Package
......
src/Base.hs
View file @ 8c3022df
......@@ -17,7 +17,7 @@ module Base (
module Development.Shake.Util,
-- * Paths
shakeFilesPath, configPath, programInplacePath,
shakeFilesPath, configPath, sourcePath, programInplacePath,
bootPackageConstraints, packageDependencies,
-- * Output
......@@ -25,8 +25,9 @@ module Base (
module System.Console.ANSI,
-- * Miscellaneous utilities
bimap, minusOrd, intersectOrd, removeFileIfExists, replaceEq, chunksOfSize,
replaceSeparators, decodeModule, encodeModule, unifyPath, (-/-), versionToInt
bimap, minusOrd, intersectOrd, removeFileIfExists, replaceEq, quote,
chunksOfSize, replaceSeparators, decodeModule, encodeModule, unifyPath,
(-/-), versionToInt
) where
import Control.Applicative
......@@ -56,6 +57,11 @@ shakeFilesPath = shakePath -/- ".db"
configPath :: FilePath
configPath = shakePath -/- "cfg"
-- | Path to source files of the build system, e.g. this file is located at
-- sourcePath -/- "Base.hs". We use this to `need` some of the source files.
sourcePath :: FilePath
sourcePath = shakePath -/- "src"
programInplacePath :: FilePath
programInplacePath = "inplace/bin"
......@@ -77,6 +83,10 @@ replaceSeparators = replaceIf isPathSeparator
replaceIf :: (a -> Bool) -> a -> [a] -> [a]
replaceIf p to = map (\from -> if p from then to else from)
-- | Add quotes to a String
quote :: String -> String
quote s = "\"" ++ s ++ "\""
-- | Given a version string such as "2.16.2" produce an integer equivalent
versionToInt :: String -> Int
versionToInt s = major * 1000 + minor * 10 + patch
......
src/Rules/Generate.hs
View file @ 8c3022df
......@@ -2,7 +2,9 @@ module Rules.Generate (generatePackageCode) where
import Expression
import GHC
import Oracles
import Rules.Generators.ConfigHs
import Rules.Generators.GhcPkgVersionHs
import Rules.Generators.PlatformH
import Oracles.ModuleFiles
import Rules.Actions
import Rules.Resources (Resources)
......@@ -78,165 +80,3 @@ generatePackageCode _ target @ (PartialTarget stage pkg) =
when (pkg == runghc) $ buildPath -/- "Main.hs" %> \file -> do
copyFileChanged (pkgPath pkg -/- "runghc.hs") file
putBuild $ "| Successfully generated '" ++ file ++ "'."
quote :: String -> String
quote s = "\"" ++ s ++ "\""
-- TODO: do we need ghc-split? Always or is it platform specific?
-- TODO: add tracking by moving these functions to separate tracked files
generateConfigHs :: Expr String
generateConfigHs = do
cProjectName <- getSetting ProjectName
cProjectGitCommitId <- getSetting ProjectGitCommitId
cProjectVersion <- getSetting ProjectVersion
cProjectVersionInt <- getSetting ProjectVersionInt
cProjectPatchLevel <- getSetting ProjectPatchLevel
cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
cBooterVersion <- getSetting GhcVersion
let cIntegerLibraryType | integerLibrary == integerGmp = "IntegerGMP"
| integerLibrary == integerSimple = "IntegerSimple"
| otherwise = error $ "Unknown integer library: "
++ show integerLibrary ++ "."
yesNo = lift . fmap (\x -> if x then "YES" else "NO")
cSupportsSplitObjs <- yesNo supportsSplitObjects
cGhcWithInterpreter <- yesNo ghcWithInterpreter
cGhcWithNativeCodeGen <- yesNo ghcWithNativeCodeGen
cGhcWithSMP <- yesNo ghcWithSMP
cGhcEnableTablesNextToCode <- yesNo ghcEnableTablesNextToCode
cLeadingUnderscore <- yesNo $ flag LeadingUnderscore
cGHC_UNLIT_PGM <- fmap takeFileName $ getBuilderPath Unlit
cGHC_SPLIT_PGM <- fmap takeBaseName $ getBuilderPath GhcSplit
cLibFFI <- lift useLibFFIForAdjustors
rtsWays <- getRtsWays
cGhcRtsWithLibdw <- getFlag WithLibdw
let cGhcRTSWays = unwords $ map show rtsWays
return $ unlines
[ "{-# LANGUAGE CPP #-}"
, "module Config where"
, ""
, "#include \"ghc_boot_platform.h\""
, ""
, "data IntegerLibrary = IntegerGMP"
, " | IntegerSimple"
, " deriving Eq"
, ""
, "cBuildPlatformString :: String"
, "cBuildPlatformString = BuildPlatform_NAME"
, "cHostPlatformString :: String"
, "cHostPlatformString = HostPlatform_NAME"
, "cTargetPlatformString :: String"
, "cTargetPlatformString = TargetPlatform_NAME"
, ""
, "cProjectName :: String"
, "cProjectName = " ++ quote cProjectName
, "cProjectGitCommitId :: String"
, "cProjectGitCommitId = " ++ quote cProjectGitCommitId
, "cProjectVersion :: String"
, "cProjectVersion = " ++ quote cProjectVersion
, "cProjectVersionInt :: String"
, "cProjectVersionInt = " ++ quote cProjectVersionInt
, "cProjectPatchLevel :: String"
, "cProjectPatchLevel = " ++ quote cProjectPatchLevel
, "cProjectPatchLevel1 :: String"
, "cProjectPatchLevel1 = " ++ quote cProjectPatchLevel1
, "cProjectPatchLevel2 :: String"
, "cProjectPatchLevel2 = " ++ quote cProjectPatchLevel2
, "cBooterVersion :: String"
, "cBooterVersion = " ++ quote cBooterVersion
, "cStage :: String"
, "cStage = show (STAGE :: Int)"
, "cIntegerLibrary :: String"
, "cIntegerLibrary = " ++ quote (pkgNameString integerLibrary)
, "cIntegerLibraryType :: IntegerLibrary"
, "cIntegerLibraryType = " ++ cIntegerLibraryType
, "cSupportsSplitObjs :: String"
, "cSupportsSplitObjs = " ++ quote cSupportsSplitObjs
, "cGhcWithInterpreter :: String"
, "cGhcWithInterpreter = " ++ quote cGhcWithInterpreter
, "cGhcWithNativeCodeGen :: String"
, "cGhcWithNativeCodeGen = " ++ quote cGhcWithNativeCodeGen
, "cGhcWithSMP :: String"
, "cGhcWithSMP = " ++ quote cGhcWithSMP
, "cGhcRTSWays :: String"
, "cGhcRTSWays = " ++ quote cGhcRTSWays
, "cGhcEnableTablesNextToCode :: String"
, "cGhcEnableTablesNextToCode = " ++ quote cGhcEnableTablesNextToCode
, "cLeadingUnderscore :: String"
, "cLeadingUnderscore = " ++ quote cLeadingUnderscore
, "cGHC_UNLIT_PGM :: String"
, "cGHC_UNLIT_PGM = " ++ quote cGHC_UNLIT_PGM
, "cGHC_SPLIT_PGM :: String"
, "cGHC_SPLIT_PGM = " ++ quote cGHC_SPLIT_PGM
, "cLibFFI :: Bool"
, "cLibFFI = " ++ show cLibFFI
, "cGhcThreaded :: Bool"
, "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
, "cGhcDebugged :: Bool"
, "cGhcDebugged = " ++ show ghcDebugged
, "cGhcRtsWithLibdw :: Bool"
, "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
generatePlatformH :: Expr String
generatePlatformH = do
stage <- getStage
let cppify = replaceEq '-' '_' . replaceEq '.' '_'
chooseSetting x y = getSetting $ if stage == Stage0 then x else y
buildPlatform <- chooseSetting BuildPlatform HostPlatform
buildArch <- chooseSetting BuildArch HostArch
buildOs <- chooseSetting BuildOs HostOs
buildVendor <- chooseSetting BuildVendor HostVendor
hostPlatform <- chooseSetting HostPlatform TargetPlatform
hostArch <- chooseSetting HostArch TargetArch
hostOs <- chooseSetting HostOs TargetOs
hostVendor <- chooseSetting HostVendor TargetVendor
targetPlatform <- getSetting TargetPlatform
targetArch <- getSetting TargetArch
targetOs <- getSetting TargetOs
targetVendor <- getSetting TargetVendor
return $ unlines
[ "#ifndef __PLATFORM_H__"
, "#define __PLATFORM_H__"
, ""
, "#define BuildPlatform_NAME " ++ quote buildPlatform
, "#define HostPlatform_NAME " ++ quote hostPlatform
, "#define TargetPlatform_NAME " ++ quote targetPlatform
, ""
, "#define " ++ cppify buildPlatform ++ "_BUILD 1"
, "#define " ++ cppify hostPlatform ++ "_HOST 1"
, "#define " ++ cppify targetPlatform ++ "_TARGET 1"
, ""
, "#define " ++ buildArch ++ "_BUILD_ARCH 1"
, "#define " ++ hostArch ++ "_HOST_ARCH 1"
, "#define " ++ targetArch ++ "_TARGET_ARCH 1"
, "#define BUILD_ARCH " ++ quote buildArch
, "#define HOST_ARCH " ++ quote hostArch
, "#define TARGET_ARCH " ++ quote targetArch
, ""
, "#define " ++ buildOs ++ "_BUILD_OS 1"
, "#define " ++ hostOs ++ "_HOST_OS 1"
, "#define " ++ targetOs ++ "_TARGET_OS 1"
, "#define BUILD_OS " ++ quote buildOs
, "#define HOST_OS " ++ quote hostOs
, "#define TARGET_OS " ++ quote targetOs
, ""
, "#define " ++ buildVendor ++ "_BUILD_VENDOR 1"
, "#define " ++ hostVendor ++ "_HOST_VENDOR 1"
, "#define " ++ targetVendor ++ "_TARGET_VENDOR 1"
, "#define BUILD_VENDOR " ++ quote buildVendor
, "#define HOST_VENDOR " ++ quote hostVendor
, "#define TARGET_VENDOR " ++ quote targetVendor
, ""
, "#endif /* __PLATFORM_H__ */" ]
generateGhcPkgVersionHs :: Expr String
generateGhcPkgVersionHs = do
projectVersion <- getSetting ProjectVersion
targetOs <- getSetting TargetOs
targetArch <- getSetting TargetArch
return $ unlines
[ "module Version where"
, "version, targetOS, targetARCH :: String"
, "version = " ++ quote projectVersion
, "targetOS = " ++ quote targetOs
, "targetARCH = " ++ quote targetArch ]
src/Rules/Generators/ConfigHs.hs 0 → 100644
View file @ 8c3022df
module Rules.Generators.ConfigHs (generateConfigHs) where
import Expression
import GHC
import Oracles
import Settings
-- TODO: do we need ghc-split? Always or is it platform specific?
-- TODO: add tracking by moving these functions to separate tracked files
generateConfigHs :: Expr String
generateConfigHs = do
lift $ need [sourcePath -/- "Rules/Generators/ConfigHs.hs"]
cProjectName <- getSetting ProjectName
cProjectGitCommitId <- getSetting ProjectGitCommitId
cProjectVersion <- getSetting ProjectVersion
cProjectVersionInt <- getSetting ProjectVersionInt
cProjectPatchLevel <- getSetting ProjectPatchLevel
cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
cBooterVersion <- getSetting GhcVersion
let cIntegerLibraryType | integerLibrary == integerGmp = "IntegerGMP"
| integerLibrary == integerSimple = "IntegerSimple"
| otherwise = error $ "Unknown integer library: "
++ show integerLibrary ++ "."
yesNo = lift . fmap (\x -> if x then "YES" else "NO")
cSupportsSplitObjs <- yesNo supportsSplitObjects
cGhcWithInterpreter <- yesNo ghcWithInterpreter
cGhcWithNativeCodeGen <- yesNo ghcWithNativeCodeGen
cGhcWithSMP <- yesNo ghcWithSMP
cGhcEnableTablesNextToCode <- yesNo ghcEnableTablesNextToCode
cLeadingUnderscore <- yesNo $ flag LeadingUnderscore
cGHC_UNLIT_PGM <- fmap takeFileName $ getBuilderPath Unlit
cGHC_SPLIT_PGM <- fmap takeBaseName $ getBuilderPath GhcSplit
cLibFFI <- lift useLibFFIForAdjustors
rtsWays <- getRtsWays
cGhcRtsWithLibdw <- getFlag WithLibdw
let cGhcRTSWays = unwords $ map show rtsWays
return $ unlines
[ "{-# LANGUAGE CPP #-}"
, "module Config where"
, ""
, "#include \"ghc_boot_platform.h\""
, ""
, "data IntegerLibrary = IntegerGMP"
, " | IntegerSimple"
, " deriving Eq"
, ""
, "cBuildPlatformString :: String"
, "cBuildPlatformString = BuildPlatform_NAME"
, "cHostPlatformString :: String"
, "cHostPlatformString = HostPlatform_NAME"
, "cTargetPlatformString :: String"
, "cTargetPlatformString = TargetPlatform_NAME"
, ""
, "cProjectName :: String"
, "cProjectName = " ++ quote cProjectName
, "cProjectGitCommitId :: String"
, "cProjectGitCommitId = " ++ quote cProjectGitCommitId
, "cProjectVersion :: String"
, "cProjectVersion = " ++ quote cProjectVersion
, "cProjectVersionInt :: String"
, "cProjectVersionInt = " ++ quote cProjectVersionInt
, "cProjectPatchLevel :: String"
, "cProjectPatchLevel = " ++ quote cProjectPatchLevel
, "cProjectPatchLevel1 :: String"
, "cProjectPatchLevel1 = " ++ quote cProjectPatchLevel1
, "cProjectPatchLevel2 :: String"
, "cProjectPatchLevel2 = " ++ quote cProjectPatchLevel2
, "cBooterVersion :: String"
, "cBooterVersion = " ++ quote cBooterVersion
, "cStage :: String"
, "cStage = show (STAGE :: Int)"
, "cIntegerLibrary :: String"
, "cIntegerLibrary = " ++ quote (pkgNameString integerLibrary)
, "cIntegerLibraryType :: IntegerLibrary"
, "cIntegerLibraryType = " ++ cIntegerLibraryType
, "cSupportsSplitObjs :: String"
, "cSupportsSplitObjs = " ++ quote cSupportsSplitObjs
, "cGhcWithInterpreter :: String"
, "cGhcWithInterpreter = " ++ quote cGhcWithInterpreter
, "cGhcWithNativeCodeGen :: String"
, "cGhcWithNativeCodeGen = " ++ quote cGhcWithNativeCodeGen
, "cGhcWithSMP :: String"
, "cGhcWithSMP = " ++ quote cGhcWithSMP
, "cGhcRTSWays :: String"
, "cGhcRTSWays = " ++ quote cGhcRTSWays
, "cGhcEnableTablesNextToCode :: String"
, "cGhcEnableTablesNextToCode = " ++ quote cGhcEnableTablesNextToCode
, "cLeadingUnderscore :: String"
, "cLeadingUnderscore = " ++ quote cLeadingUnderscore
, "cGHC_UNLIT_PGM :: String"
, "cGHC_UNLIT_PGM = " ++ quote cGHC_UNLIT_PGM
, "cGHC_SPLIT_PGM :: String"
, "cGHC_SPLIT_PGM = " ++ quote cGHC_SPLIT_PGM
, "cLibFFI :: Bool"
, "cLibFFI = " ++ show cLibFFI
, "cGhcThreaded :: Bool"
, "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
, "cGhcDebugged :: Bool"
, "cGhcDebugged = " ++ show ghcDebugged
, "cGhcRtsWithLibdw :: Bool"
, "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
src/Rules/Generators/GhcPkgVersionHs.hs 0 → 100644
View file @ 8c3022df
module Rules.Generators.GhcPkgVersionHs (generateGhcPkgVersionHs) where
import Expression
import Oracles
generateGhcPkgVersionHs :: Expr String
generateGhcPkgVersionHs = do
lift $ need [sourcePath -/- "Rules/Generators/GhcPkgVersionHs.hs"]
projectVersion <- getSetting ProjectVersion
targetOs <- getSetting TargetOs
targetArch <- getSetting TargetArch
return $ unlines
[ "module Version where"
, "version, targetOS, targetARCH :: String"
, "version = " ++ quote projectVersion
, "targetOS = " ++ quote targetOs
, "targetARCH = " ++ quote targetArch ]
src/Rules/Generators/PlatformH.hs 0 → 100644
View file @ 8c3022df
module Rules.Generators.PlatformH (generatePlatformH) where
import Expression
import Oracles
generatePlatformH :: Expr String
generatePlatformH = do
lift $ need [sourcePath -/- "Rules/Generators/PlatformH.hs"]
stage <- getStage
let cppify = replaceEq '-' '_' . replaceEq '.' '_'
chooseSetting x y = getSetting $ if stage == Stage0 then x else y
buildPlatform <- chooseSetting BuildPlatform HostPlatform
buildArch <- chooseSetting BuildArch HostArch
buildOs <- chooseSetting BuildOs HostOs
buildVendor <- chooseSetting BuildVendor HostVendor
hostPlatform <- chooseSetting HostPlatform TargetPlatform
hostArch <- chooseSetting HostArch TargetArch
hostOs <- chooseSetting HostOs TargetOs
hostVendor <- chooseSetting HostVendor TargetVendor
targetPlatform <- getSetting TargetPlatform
targetArch <- getSetting TargetArch
targetOs <- getSetting TargetOs
targetVendor <- getSetting TargetVendor
return $ unlines
[ "#ifndef __PLATFORM_H__"
, "#define __PLATFORM_H__"
, ""
, "#define BuildPlatform_NAME " ++ quote buildPlatform
, "#define HostPlatform_NAME " ++ quote hostPlatform
, "#define TargetPlatform_NAME " ++ quote targetPlatform
, ""
, "#define " ++ cppify buildPlatform ++ "_BUILD 1"
, "#define " ++ cppify hostPlatform ++ "_HOST 1"
, "#define " ++ cppify targetPlatform ++ "_TARGET 1"
, ""
, "#define " ++ buildArch ++ "_BUILD_ARCH 1"
, "#define " ++ hostArch ++ "_HOST_ARCH 1"
, "#define " ++ targetArch ++ "_TARGET_ARCH 1"
, "#define BUILD_ARCH " ++ quote buildArch
, "#define HOST_ARCH " ++ quote hostArch
, "#define TARGET_ARCH " ++ quote targetArch
, ""
, "#define " ++ buildOs ++ "_BUILD_OS 1"
, "#define " ++ hostOs ++ "_HOST_OS 1"
, "#define " ++ targetOs ++ "_TARGET_OS 1"
, "#define BUILD_OS " ++ quote buildOs
, "#define HOST_OS " ++ quote hostOs
, "#define TARGET_OS " ++ quote targetOs
, ""
, "#define " ++ buildVendor ++ "_BUILD_VENDOR 1"
, "#define " ++ hostVendor ++ "_HOST_VENDOR 1"
, "#define " ++ targetVendor ++ "_TARGET_VENDOR 1"
, "#define BUILD_VENDOR " ++ quote buildVendor
, "#define HOST_VENDOR " ++ quote hostVendor
, "#define TARGET_VENDOR " ++ quote targetVendor
, ""
, "#endif /* __PLATFORM_H__ */" ]
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment