Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
8e97252e
Commit
8e97252e
authored
Aug 06, 2017
by
Andrey Mokhov
Browse files
Merge all generators into a single file, factor our common functionality into the library.
See
#347
parent
df8e5aa8
Changes
25
Hide whitespace changes
Inline
Side-by-side
hadrian.cabal
View file @
8e97252e
...
...
@@ -49,14 +49,6 @@ executable hadrian
, Rules.Dependencies
, Rules.Documentation
, Rules.Generate
, Rules.Generators.Common
, Rules.Generators.ConfigHs
, Rules.Generators.GhcAutoconfH
, Rules.Generators.GhcBootPlatformH
, Rules.Generators.GhcPlatformH
, Rules.Generators.GhcSplit
, Rules.Generators.GhcVersionH
, Rules.Generators.VersionHs
, Rules.Gmp
, Rules.Install
, Rules.Libffi
...
...
src/Base.hs
View file @
8e97252e
...
...
@@ -17,8 +17,8 @@ module Base (
configPath
,
configFile
,
sourcePath
,
-- * Miscellaneous utilities
minusOrd
,
intersectOrd
,
lookupAll
,
replaceEq
,
replaceSeparators
,
unify
Path
,
quote
,
(
-/-
),
matchVersionedFilePath
,
matchGhcVersionedFilePath
,
putColoured
unifyPath
,
quote
,
(
-/-
),
matchVersionedFilePath
,
matchGhcVersionedFile
Path
,
putColoured
)
where
import
Control.Applicative
...
...
@@ -58,53 +58,6 @@ configFile = configPath -/- "system.config"
sourcePath
::
FilePath
sourcePath
=
hadrianPath
-/-
"src"
-- | Find and replace all occurrences of a value in a list.
replaceEq
::
Eq
a
=>
a
->
a
->
[
a
]
->
[
a
]
replaceEq
from
=
replaceWhen
(
==
from
)
-- | Find and replace all occurrences of path separators in a String with a Char.
replaceSeparators
::
Char
->
String
->
String
replaceSeparators
=
replaceWhen
isPathSeparator
replaceWhen
::
(
a
->
Bool
)
->
a
->
[
a
]
->
[
a
]
replaceWhen
p
to
=
map
(
\
from
->
if
p
from
then
to
else
from
)
-- Explicit definition to avoid dependency on Data.List.Ordered
-- | Difference of two ordered lists.
minusOrd
::
Ord
a
=>
[
a
]
->
[
a
]
->
[
a
]
minusOrd
[]
_
=
[]
minusOrd
xs
[]
=
xs
minusOrd
(
x
:
xs
)
(
y
:
ys
)
=
case
compare
x
y
of
LT
->
x
:
minusOrd
xs
(
y
:
ys
)
EQ
->
minusOrd
xs
ys
GT
->
minusOrd
(
x
:
xs
)
ys
-- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
-- | Intersection of two ordered lists by a predicate.
intersectOrd
::
(
a
->
b
->
Ordering
)
->
[
a
]
->
[
b
]
->
[
a
]
intersectOrd
cmp
=
loop
where
loop
[]
_
=
[]
loop
_
[]
=
[]
loop
(
x
:
xs
)
(
y
:
ys
)
=
case
cmp
x
y
of
LT
->
loop
xs
(
y
:
ys
)
EQ
->
x
:
loop
xs
(
y
:
ys
)
GT
->
loop
(
x
:
xs
)
ys
-- | Lookup all elements of a given sorted list in a given sorted dictionary.
-- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
-- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
--
-- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
-- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
lookupAll
::
Ord
a
=>
[
a
]
->
[(
a
,
b
)]
->
[
Maybe
b
]
lookupAll
[]
_
=
[]
lookupAll
(
_
:
xs
)
[]
=
Nothing
:
lookupAll
xs
[]
lookupAll
(
x
:
xs
)
(
y
:
ys
)
=
case
compare
x
(
fst
y
)
of
LT
->
Nothing
:
lookupAll
xs
(
y
:
ys
)
EQ
->
Just
(
snd
y
)
:
lookupAll
xs
(
y
:
ys
)
GT
->
lookupAll
(
x
:
xs
)
ys
-- | Given a @prefix@ and a @suffix@ check whether a @filePath@ matches the
-- template @prefix ++ version ++ suffix@ where @version@ is an arbitrary string
-- comprising digits (@0-9@), dashes (@-@), and dots (@.@). Examples:
...
...
src/Expression.hs
View file @
8e97252e
...
...
@@ -13,7 +13,7 @@ module Expression (
-- * Convenient accessors
getContext
,
getStage
,
getPackage
,
getBuilder
,
getOutputs
,
getInputs
,
getWay
,
getInput
,
getOutput
,
getSingleton
,
getSetting
,
getSettingList
,
getFlag
,
getInput
,
getOutput
,
getSetting
,
getSettingList
,
getFlag
,
-- * Re-exports
module
Data
.
Semigroup
,
...
...
src/Hadrian/Expression.hs
View file @
8e97252e
...
...
@@ -11,7 +11,7 @@ module Hadrian.Expression (
interpret
,
interpretInContext
,
-- * Convenient accessors
getContext
,
getBuilder
,
getOutputs
,
getInputs
,
getInput
,
getOutput
,
getSingleton
getContext
,
getBuilder
,
getOutputs
,
getInputs
,
getInput
,
getOutput
)
where
import
Control.Monad.Trans
...
...
@@ -20,6 +20,7 @@ import Data.Semigroup
import
Development.Shake
import
Hadrian.Target
import
Hadrian.Utilities
-- | 'Expr' @c b a@ is a computation that produces a value of type 'Action' @a@
-- and can read parameters of the current build 'Target' @c b@.
...
...
@@ -106,7 +107,7 @@ getInputs = Expr $ asks inputs
getInput
::
(
Show
b
,
Show
c
)
=>
Expr
c
b
FilePath
getInput
=
Expr
$
do
target
<-
ask
get
Singleton
(
"Exactly one input file expected in "
++
show
target
)
<$>
asks
inputs
from
Singleton
(
"Exactly one input file expected in "
++
show
target
)
<$>
asks
inputs
-- | Get the files produced by the current 'Target'.
getOutputs
::
Expr
c
b
[
FilePath
]
...
...
@@ -116,10 +117,4 @@ getOutputs = Expr $ asks outputs
getOutput
::
(
Show
b
,
Show
c
)
=>
Expr
c
b
FilePath
getOutput
=
Expr
$
do
target
<-
ask
getSingleton
(
"Exactly one output file expected in "
++
show
target
)
<$>
asks
outputs
-- | Extract a value from a singleton list, or raise an error if the list does
-- not contain exactly one value.
getSingleton
::
String
->
[
a
]
->
a
getSingleton
_
[
res
]
=
res
getSingleton
msg
_
=
error
msg
fromSingleton
(
"Exactly one output file expected in "
++
show
target
)
<$>
asks
outputs
src/Hadrian/Utilities.hs
View file @
8e97252e
module
Hadrian.Utilities
(
-- * List manipulation
fromSingleton
,
replaceEq
,
minusOrd
,
intersectOrd
,
lookupAll
,
-- * String manipulation
quote
,
quote
,
yesNo
,
-- * FilePath manipulation
unifyPath
,
(
-/-
)
...
...
@@ -9,10 +12,61 @@ module Hadrian.Utilities (
import
Development.Shake.FilePath
-- | Extract a value from a singleton list, or terminate with an error message
-- if the list does not contain exactly one value.
fromSingleton
::
String
->
[
a
]
->
a
fromSingleton
_
[
res
]
=
res
fromSingleton
msg
_
=
error
msg
-- | Find and replace all occurrences of a value in a list.
replaceEq
::
Eq
a
=>
a
->
a
->
[
a
]
->
[
a
]
replaceEq
from
to
=
map
(
\
cur
->
if
cur
==
from
then
to
else
cur
)
-- Explicit definition to avoid dependency on Data.List.Ordered
-- | Difference of two ordered lists.
minusOrd
::
Ord
a
=>
[
a
]
->
[
a
]
->
[
a
]
minusOrd
[]
_
=
[]
minusOrd
xs
[]
=
xs
minusOrd
(
x
:
xs
)
(
y
:
ys
)
=
case
compare
x
y
of
LT
->
x
:
minusOrd
xs
(
y
:
ys
)
EQ
->
minusOrd
xs
ys
GT
->
minusOrd
(
x
:
xs
)
ys
-- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
-- | Intersection of two ordered lists by a predicate.
intersectOrd
::
(
a
->
b
->
Ordering
)
->
[
a
]
->
[
b
]
->
[
a
]
intersectOrd
cmp
=
loop
where
loop
[]
_
=
[]
loop
_
[]
=
[]
loop
(
x
:
xs
)
(
y
:
ys
)
=
case
cmp
x
y
of
LT
->
loop
xs
(
y
:
ys
)
EQ
->
x
:
loop
xs
(
y
:
ys
)
GT
->
loop
(
x
:
xs
)
ys
-- | Lookup all elements of a given sorted list in a given sorted dictionary.
-- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
-- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
--
-- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
-- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
lookupAll
::
Ord
a
=>
[
a
]
->
[(
a
,
b
)]
->
[
Maybe
b
]
lookupAll
[]
_
=
[]
lookupAll
(
_
:
xs
)
[]
=
Nothing
:
lookupAll
xs
[]
lookupAll
(
x
:
xs
)
(
y
:
ys
)
=
case
compare
x
(
fst
y
)
of
LT
->
Nothing
:
lookupAll
xs
(
y
:
ys
)
EQ
->
Just
(
snd
y
)
:
lookupAll
xs
(
y
:
ys
)
GT
->
lookupAll
(
x
:
xs
)
ys
-- | Add single quotes around a String.
quote
::
String
->
String
quote
s
=
"'"
++
s
++
"'"
-- | Pretty-print a 'Bool' as a @"YES"@ or @"NO"@ string.
yesNo
::
Bool
->
String
yesNo
True
=
"YES"
yesNo
False
=
"NO"
-- | Normalise a path and convert all path separators to @/@, even on Windows.
unifyPath
::
FilePath
->
FilePath
unifyPath
=
toStandard
.
normaliseEx
...
...
src/Oracles/Dependencies.hs
View file @
8e97252e
...
...
@@ -5,6 +5,7 @@ module Oracles.Dependencies (
)
where
import
qualified
Data.HashMap.Strict
as
Map
import
Hadrian.Utilities
import
Base
import
Context
...
...
src/Oracles/ModuleFiles.hs
View file @
8e97252e
...
...
@@ -4,6 +4,7 @@ module Oracles.ModuleFiles (
)
where
import
qualified
Data.HashMap.Strict
as
Map
import
Hadrian.Utilities
import
Base
import
Context
...
...
src/Rules/Configure.hs
View file @
8e97252e
...
...
@@ -7,7 +7,7 @@ import Builder
import
CmdLineFlag
import
Context
import
GHC
import
Rules.Generators.GhcAutoconfH
import
Settings.Path
import
Stage
import
Target
import
UserSettings
...
...
src/Rules/Generate.hs
View file @
8e97252e
...
...
@@ -3,20 +3,17 @@ module Rules.Generate (
copyRules
,
includesDependencies
,
generatedDependencies
)
where
import
Hadrian.Utilities
import
Base
import
Context
hiding
(
package
)
import
Expression
import
Flavour
import
GHC
import
Oracles.Config.Flag
import
Oracles.Config.Setting
import
Oracles.ModuleFiles
import
Predicate
import
Rules.Generators.ConfigHs
import
Rules.Generators.GhcAutoconfH
import
Rules.Generators.GhcBootPlatformH
import
Rules.Generators.GhcPlatformH
import
Rules.Generators.GhcSplit
import
Rules.Generators.GhcVersionH
import
Rules.Generators.VersionHs
import
Rules.Libffi
import
Settings
import
Settings.Path
...
...
@@ -24,6 +21,10 @@ import Target
import
UserSettings
import
Util
-- | Track this file to rebuild generated files whenever it changes.
trackGenerateHs
::
Expr
()
trackGenerateHs
=
expr
$
need
[
sourcePath
-/-
"Rules/Generate.hs"
]
primopsSource
::
FilePath
primopsSource
=
"compiler/prelude/primops.txt.pp"
...
...
@@ -171,3 +172,298 @@ generateRules = do
emptyTarget
::
Context
emptyTarget
=
vanillaContext
(
error
"Rules.Generate.emptyTarget: unknown stage"
)
(
error
"Rules.Generate.emptyTarget: unknown package"
)
-- Generators
-- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
-- the resulting 'String' is a valid C preprocessor identifier.
cppify
::
String
->
String
cppify
=
replaceEq
'-'
'_'
.
replaceEq
'.'
'_'
ghcSplitSource
::
FilePath
ghcSplitSource
=
"driver/split/ghc-split.pl"
-- ref: rules/build-perl.mk
-- | Generate the @ghc-split@ Perl script.
generateGhcSplit
::
Expr
String
generateGhcSplit
=
do
trackGenerateHs
targetPlatform
<-
getSetting
TargetPlatform
ghcEnableTNC
<-
expr
$
yesNo
<$>
ghcEnableTablesNextToCode
perlPath
<-
getBuilderPath
Perl
contents
<-
expr
$
readFileLines
ghcSplitSource
return
.
unlines
$
[
"#!"
++
perlPath
,
"my $TARGETPLATFORM = "
++
show
targetPlatform
++
";"
-- I don't see where the ghc-split tool uses TNC, but
-- it's in the build-perl macro.
,
"my $TABLES_NEXT_TO_CODE = "
++
show
ghcEnableTNC
++
";"
]
++
contents
-- | Generate @ghcplatform.h@ header.
generateGhcPlatformH
::
Expr
String
generateGhcPlatformH
=
do
trackGenerateHs
hostPlatform
<-
getSetting
HostPlatform
hostArch
<-
getSetting
HostArch
hostOs
<-
getSetting
HostOs
hostVendor
<-
getSetting
HostVendor
targetPlatform
<-
getSetting
TargetPlatform
targetArch
<-
getSetting
TargetArch
targetOs
<-
getSetting
TargetOs
targetVendor
<-
getSetting
TargetVendor
ghcUnreg
<-
getFlag
GhcUnregisterised
return
.
unlines
$
[
"#ifndef __GHCPLATFORM_H__"
,
"#define __GHCPLATFORM_H__"
,
""
,
"#define BuildPlatform_TYPE "
++
cppify
hostPlatform
,
"#define HostPlatform_TYPE "
++
cppify
targetPlatform
,
""
,
"#define "
++
cppify
hostPlatform
++
"_BUILD 1"
,
"#define "
++
cppify
targetPlatform
++
"_HOST 1"
,
""
,
"#define "
++
hostArch
++
"_BUILD_ARCH 1"
,
"#define "
++
targetArch
++
"_HOST_ARCH 1"
,
"#define BUILD_ARCH "
++
show
hostArch
,
"#define HOST_ARCH "
++
show
targetArch
,
""
,
"#define "
++
hostOs
++
"_BUILD_OS 1"
,
"#define "
++
targetOs
++
"_HOST_OS 1"
,
"#define BUILD_OS "
++
show
hostOs
,
"#define HOST_OS "
++
show
targetOs
,
""
,
"#define "
++
hostVendor
++
"_BUILD_VENDOR 1"
,
"#define "
++
targetVendor
++
"_HOST_VENDOR 1"
,
"#define BUILD_VENDOR "
++
show
hostVendor
,
"#define HOST_VENDOR "
++
show
targetVendor
,
""
,
"/* These TARGET macros are for backwards compatibility... DO NOT USE! */"
,
"#define TargetPlatform_TYPE "
++
cppify
targetPlatform
,
"#define "
++
cppify
targetPlatform
++
"_TARGET 1"
,
"#define "
++
targetArch
++
"_TARGET_ARCH 1"
,
"#define TARGET_ARCH "
++
show
targetArch
,
"#define "
++
targetOs
++
"_TARGET_OS 1"
,
"#define TARGET_OS "
++
show
targetOs
,
"#define "
++
targetVendor
++
"_TARGET_VENDOR 1"
]
++
[
"#define UnregisterisedCompiler 1"
|
ghcUnreg
]
++
[
"
\n
#endif /* __GHCPLATFORM_H__ */"
]
-- | Generate @Config.hs@ files.
generateConfigHs
::
Expr
String
generateConfigHs
=
do
trackGenerateHs
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
flavour
==
integerGmp
=
"IntegerGMP"
|
integerLibrary
flavour
==
integerSimple
=
"IntegerSimple"
|
otherwise
=
error
$
"Unknown integer library: "
++
integerLibraryName
cSupportsSplitObjs
<-
expr
$
yesNo
<$>
supportsSplitObjects
cGhcWithInterpreter
<-
expr
$
yesNo
<$>
ghcWithInterpreter
cGhcWithNativeCodeGen
<-
expr
$
yesNo
<$>
ghcWithNativeCodeGen
cGhcWithSMP
<-
expr
$
yesNo
<$>
ghcWithSMP
cGhcEnableTablesNextToCode
<-
expr
$
yesNo
<$>
ghcEnableTablesNextToCode
cLeadingUnderscore
<-
expr
$
yesNo
<$>
flag
LeadingUnderscore
cGHC_UNLIT_PGM
<-
fmap
takeFileName
$
getBuilderPath
Unlit
cLibFFI
<-
expr
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 = "
++
show
cProjectName
,
"cProjectGitCommitId :: String"
,
"cProjectGitCommitId = "
++
show
cProjectGitCommitId
,
"cProjectVersion :: String"
,
"cProjectVersion = "
++
show
cProjectVersion
,
"cProjectVersionInt :: String"
,
"cProjectVersionInt = "
++
show
cProjectVersionInt
,
"cProjectPatchLevel :: String"
,
"cProjectPatchLevel = "
++
show
cProjectPatchLevel
,
"cProjectPatchLevel1 :: String"
,
"cProjectPatchLevel1 = "
++
show
cProjectPatchLevel1
,
"cProjectPatchLevel2 :: String"
,
"cProjectPatchLevel2 = "
++
show
cProjectPatchLevel2
,
"cBooterVersion :: String"
,
"cBooterVersion = "
++
show
cBooterVersion
,
"cStage :: String"
,
"cStage = show (STAGE :: Int)"
,
"cIntegerLibrary :: String"
,
"cIntegerLibrary = "
++
show
integerLibraryName
,
"cIntegerLibraryType :: IntegerLibrary"
,
"cIntegerLibraryType = "
++
cIntegerLibraryType
,
"cSupportsSplitObjs :: String"
,
"cSupportsSplitObjs = "
++
show
cSupportsSplitObjs
,
"cGhcWithInterpreter :: String"
,
"cGhcWithInterpreter = "
++
show
cGhcWithInterpreter
,
"cGhcWithNativeCodeGen :: String"
,
"cGhcWithNativeCodeGen = "
++
show
cGhcWithNativeCodeGen
,
"cGhcWithSMP :: String"
,
"cGhcWithSMP = "
++
show
cGhcWithSMP
,
"cGhcRTSWays :: String"
,
"cGhcRTSWays = "
++
show
cGhcRTSWays
,
"cGhcEnableTablesNextToCode :: String"
,
"cGhcEnableTablesNextToCode = "
++
show
cGhcEnableTablesNextToCode
,
"cLeadingUnderscore :: String"
,
"cLeadingUnderscore = "
++
show
cLeadingUnderscore
,
"cGHC_UNLIT_PGM :: String"
,
"cGHC_UNLIT_PGM = "
++
show
cGHC_UNLIT_PGM
,
"cGHC_SPLIT_PGM :: String"
,
"cGHC_SPLIT_PGM = "
++
show
"ghc-split"
,
"cLibFFI :: Bool"
,
"cLibFFI = "
++
show
cLibFFI
,
"cGhcThreaded :: Bool"
,
"cGhcThreaded = "
++
show
(
threaded
`
elem
`
rtsWays
)
,
"cGhcDebugged :: Bool"
,
"cGhcDebugged = "
++
show
(
ghcDebugged
flavour
)
,
"cGhcRtsWithLibdw :: Bool"
,
"cGhcRtsWithLibdw = "
++
show
cGhcRtsWithLibdw
]
-- | Generate @ghcautoconf.h@ header.
generateGhcAutoconfH
::
Expr
String
generateGhcAutoconfH
=
do
trackGenerateHs
configHContents
<-
expr
$
map
undefinePackage
<$>
readFileLines
configH
tablesNextToCode
<-
expr
ghcEnableTablesNextToCode
ghcUnreg
<-
getFlag
GhcUnregisterised
ccLlvmBackend
<-
getSetting
CcLlvmBackend
ccClangBackend
<-
getSetting
CcClangBackend
return
.
unlines
$
[
"#ifndef __GHCAUTOCONF_H__"
,
"#define __GHCAUTOCONF_H__"
]
++
configHContents
++
[
"
\n
#define TABLES_NEXT_TO_CODE 1"
|
tablesNextToCode
&&
not
ghcUnreg
]
++
[
"
\n
#define llvm_CC_FLAVOR 1"
|
ccLlvmBackend
==
"1"
]
++
[
"
\n
#define clang_CC_FLAVOR 1"
|
ccClangBackend
==
"1"
]
++
[
"#endif /* __GHCAUTOCONF_H__ */"
]
where
undefinePackage
s
|
"#define PACKAGE_"
`
isPrefixOf
`
s
=
"/* #undef "
++
takeWhile
(
/=
' '
)
(
drop
8
s
)
++
" */"
|
otherwise
=
s
-- | Generate @ghc_boot_platform.h@ headers.
generateGhcBootPlatformH
::
Expr
String
generateGhcBootPlatformH
=
do
trackGenerateHs
stage
<-
getStage
let
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 "
++
show
buildPlatform
,
"#define HostPlatform_NAME "
++
show
hostPlatform
,
"#define TargetPlatform_NAME "
++
show
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 "
++
show
buildArch
,
"#define HOST_ARCH "
++
show
hostArch
,
"#define TARGET_ARCH "
++
show
targetArch
,
""
,
"#define "
++
buildOs
++
"_BUILD_OS 1"
,
"#define "
++
hostOs
++
"_HOST_OS 1"
,
"#define "
++
targetOs
++
"_TARGET_OS 1"
,
"#define BUILD_OS "
++
show
buildOs
,
"#define HOST_OS "
++
show
hostOs
,
"#define TARGET_OS "
++
show
targetOs
,
""
,
"#define "
++
buildVendor
++
"_BUILD_VENDOR 1"
,
"#define "
++
hostVendor
++
"_HOST_VENDOR 1"
,
"#define "
++
targetVendor
++
"_TARGET_VENDOR 1"
,
"#define BUILD_VENDOR "
++
show
buildVendor
,
"#define HOST_VENDOR "
++
show
hostVendor
,
"#define TARGET_VENDOR "
++
show
targetVendor
,
""
,
"#endif /* __PLATFORM_H__ */"
]
-- | Generate @ghcversion.h@ header.
generateGhcVersionH
::
Expr
String
generateGhcVersionH
=
do
trackGenerateHs
version
<-
getSetting
ProjectVersionInt
patchLevel1
<-
getSetting
ProjectPatchLevel1
patchLevel2
<-
getSetting
ProjectPatchLevel2
return
.
unlines
$
[
"#ifndef __GHCVERSION_H__"
,
"#define __GHCVERSION_H__"
,
""
,
"#ifndef __GLASGOW_HASKELL__"
,
"# define __GLASGOW_HASKELL__ "
++
version
,
"#endif"
,
""
]
++
[
"#define __GLASGOW_HASKELL_PATCHLEVEL1__ "
++
patchLevel1
|
patchLevel1
/=
""
]
++
[
"#define __GLASGOW_HASKELL_PATCHLEVEL2__ "
++
patchLevel2
|
patchLevel2
/=
""
]
++
[
""
,
"#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (
\\
"
,
" ((ma)*100+(mi)) < __GLASGOW_HASKELL__ ||
\\
"
,
" ((ma)*100+(mi)) == __GLASGOW_HASKELL__
\\
"
,
" && (pl1) < __GLASGOW_HASKELL_PATCHLEVEL1__ ||
\\
"
,
" ((ma)*100+(mi)) == __GLASGOW_HASKELL__
\\
"
,
" && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__
\\
"
,
" && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )"
,
""
,
"#endif /* __GHCVERSION_H__ */"
]
-- | Generate @Version.hs@ files.
generateVersionHs
::
Expr
String
generateVersionHs
=
do
trackGenerateHs
projectVersion
<-
getSetting
ProjectVersion
targetOs
<-
getSetting
TargetOs
targetArch
<-
getSetting
TargetArch
return
$
unlines
[
"module Version where"
,
"version, targetOS, targetARCH :: String"
,
"version = "
++
show
projectVersion
,
"targetOS = "
++
show
targetOs
,
"targetARCH = "
++
show
targetArch
]
src/Rules/Generators/Common.hs
deleted
100644 → 0
View file @
df8e5aa8
module
Rules.Generators.Common
(
trackSource
,
yesNo
,
cppify
)
where
import
Base
import
Expression
-- | Track a given source file when constructing an expression.
trackSource
::
FilePath
->
Expr
()
trackSource
file
=
expr
$
need
[
sourcePath
-/-
file
]
-- | Turn a 'Bool' computed by an 'Action' into a 'String' expression returning
-- "YES" (when the Boolean is 'True') or "NO" (when the Boolean is 'False').
yesNo
::
Action
Bool
->
Expr
String
yesNo
=
expr
.
fmap
(
\
x
->
if
x
then
"YES"
else
"NO"
)
-- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
-- the resulting 'String' becomes a valid C identifier.
cppify
::
String
->
String
cppify
=
replaceEq
'-'
'_'
.
replaceEq
'.'
'_'
src/Rules/Generators/ConfigHs.hs
deleted
100644 → 0
View file @
df8e5aa8
module
Rules.Generators.ConfigHs
(
generateConfigHs
)
where
import
Base
import
Expression
import
Flavour
import
GHC
import
Oracles.Config.Flag
import
Oracles.Config.Setting
import
Rules.Generators.Common
import
Settings
generateConfigHs
::
Expr
String
generateConfigHs
=
do
trackSource
"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
flavour
==
integerGmp
=
"IntegerGMP"
|
integerLibrary
flavour
==
integerSimple
=
"IntegerSimple"
|
otherwise
=
error
$
"Unknown integer library: "
++
integerLibraryName
cSupportsSplitObjs
<-
yesNo
supportsSplitObjects
cGhcWithInterpreter
<-
yesNo
ghcWithInterpreter
cGhcWithNativeCodeGen
<-
yesNo
ghcWithNativeCodeGen
cGhcWithSMP
<-
yesNo
ghcWithSMP
cGhcEnableTablesNextToCode
<-
yesNo
ghcEnableTablesNextToCode