Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
8c3022df
Commit
8c3022df
authored
Dec 26, 2015
by
Andrey Mokhov
Browse files
Move generators to a dedicated directory, and track their changes.
parent
bdb88c61
Changes
6
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__ */"
]
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment