Skip to content
GitLab
Menu
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
b2533979
Commit
b2533979
authored
Jul 20, 2015
by
Andrey Mokhov
Browse files
Migrate all user-configurable settings from system.default to Settings/User.hs.
parent
6e8416e2
Changes
12
Hide whitespace changes
Inline
Side-by-side
cfg/system.config.in
View file @
b2533979
...
...
@@ -32,8 +32,6 @@ gcc-lt-46 = @GccLT46@
# Build options:
#===============
lax-dependencies = NO
dynamic-ghc-programs = NO
supports-package-key = @SUPPORTS_PACKAGE_KEY@
solaris-broken-shld = @SOLARIS_BROKEN_SHLD@
split-objects-broken = @SplitObjsBroken@
...
...
@@ -74,8 +72,6 @@ conf-ld-linker-args-stage0 = @CONF_LD_LINKER_OPTS_STAGE0@
conf-ld-linker-args-stage1 = @CONF_LD_LINKER_OPTS_STAGE1@
conf-ld-linker-args-stage2 = @CONF_LD_LINKER_OPTS_STAGE2@
src-hc-args = -H32m -O
# Include and library directories:
#=================================
...
...
src/Builder.hs
View file @
b2533979
{-# LANGUAGE DeriveGeneric #-}
module
Builder
(
Builder
(
..
),
builderKey
,
builderPath
,
needBuilder
Builder
(
..
),
builderKey
,
builderPath
,
specified
)
where
import
Util
import
Stage
import
Data.List
import
Oracles.Base
import
Oracles.Flag
import
Oracles.Setting
import
GHC.Generics
...
...
@@ -56,6 +55,9 @@ builderPath builder = do
++
"' in configuration files."
fixAbsolutePathOnWindows
$
if
null
path
then
""
else
path
-<.>
exe
specified
::
Builder
->
Action
Bool
specified
=
fmap
(
not
.
null
)
.
builderPath
-- TODO: get rid of code duplication (windowsHost)
-- On Windows: if the path starts with "/", prepend it with the correct path to
-- the root, e.g: "/usr/local/bin/ghc.exe" => "C:/msys/usr/local/bin/ghc.exe".
...
...
@@ -76,17 +78,6 @@ fixAbsolutePathOnWindows path = do
-- certain situations this can lead to build failures, in which case you
-- should reset the flag (at least temporarily).
-- Make sure the builder exists on the given path and rebuild it if out of date
needBuilder
::
Builder
->
Action
()
needBuilder
ghc
@
(
Ghc
stage
)
=
do
path
<-
builderPath
ghc
laxDeps
<-
test
LaxDeps
if
laxDeps
then
orderOnly
[
path
]
else
need
[
path
]
needBuilder
builder
=
do
path
<-
builderPath
builder
need
[
path
]
-- Instances for storing in the Shake database
instance
Binary
Builder
instance
Hashable
Builder
src/Expression.hs
View file @
b2533979
...
...
@@ -4,11 +4,11 @@ module Expression (
module
Data
.
Monoid
,
module
Control
.
Monad
.
Reader
,
Expr
,
DiffExpr
,
fromDiffExpr
,
Predicate
,
Args
,
Ways
,
Packages
,
Predicate
,
PredicateLike
(
..
),
applyPredicate
,
(
??
),
Args
,
Ways
,
Packages
,
append
,
appendM
,
remove
,
appendSub
,
appendSubD
,
filterSub
,
removeSub
,
interpret
,
interpretExpr
,
applyPredicate
,
(
?
),
(
??
),
stage
,
package
,
builder
,
file
,
way
,
configKeyValue
,
configKeyValues
stage
,
package
,
builder
,
file
,
way
)
where
import
Way
...
...
@@ -72,11 +72,28 @@ applyPredicate predicate expr = do
if
bool
then
expr
else
return
mempty
-- A convenient operator for predicate application
(
?
)
::
Monoid
a
=>
Predicate
->
Expr
a
->
Expr
a
(
?
)
=
applyPredicate
class
PredicateLike
a
where
(
?
)
::
Monoid
m
=>
a
->
Expr
m
->
Expr
m
notP
::
a
->
Predicate
infixr
8
?
instance
PredicateLike
Predicate
where
(
?
)
=
applyPredicate
notP
=
liftM
not
instance
PredicateLike
Bool
where
(
?
)
=
applyPredicate
.
return
notP
=
return
.
not
instance
PredicateLike
(
Action
Bool
)
where
(
?
)
=
applyPredicate
.
lift
notP
=
lift
.
fmap
not
-- An equivalent of if-then-else for predicates
(
??
)
::
(
PredicateLike
a
,
Monoid
m
)
=>
a
->
(
Expr
m
,
Expr
m
)
->
Expr
m
p
??
(
t
,
f
)
=
p
?
t
<>
notP
p
?
f
-- A monadic version of append
appendM
::
Monoid
a
=>
Action
a
->
DiffExpr
a
appendM
mx
=
lift
mx
>>=
append
...
...
@@ -126,10 +143,6 @@ fromDiffExpr = fmap (($ mempty) . fromDiff)
interpret
::
Monoid
a
=>
Target
->
DiffExpr
a
->
Action
a
interpret
target
=
interpretExpr
target
.
fromDiffExpr
-- An equivalent of if-then-else for predicates
(
??
)
::
Monoid
a
=>
Predicate
->
(
Expr
a
,
Expr
a
)
->
Expr
a
p
??
(
t
,
f
)
=
p
?
t
<>
(
liftM
not
p
)
?
f
-- Basic predicates (see Switches.hs for derived predicates)
stage
::
Stage
->
Predicate
stage
s
=
liftM
(
s
==
)
(
asks
getStage
)
...
...
@@ -145,11 +158,3 @@ file f = liftM (any (f ?==)) (asks getFiles)
way
::
Way
->
Predicate
way
w
=
liftM
(
w
==
)
(
asks
getWay
)
configKeyValue
::
String
->
String
->
Predicate
configKeyValue
key
value
=
liftM
(
value
==
)
(
lift
$
askConfig
key
)
-- Check if there is at least one match
-- Example: configKeyValues "host-os-cpp" ["mingw32", "cygwin32"]
configKeyValues
::
String
->
[
String
]
->
Predicate
configKeyValues
key
values
=
liftM
(`
elem
`
values
)
(
lift
$
askConfig
key
)
src/Oracles/Flag.hs
View file @
b2533979
module
Oracles.Flag
(
Flag
(
..
),
test
Flag
(
..
),
flag
,
supportsPackageKey
,
crossCompiling
,
gccIsClang
,
gccLt46
,
platformSupportsSharedLibs
)
where
import
Util
import
Oracles.Base
import
Oracles.Setting
import
Control.Monad
data
Flag
=
LaxDeps
|
DynamicGhcPrograms
|
GccIsClang
data
Flag
=
GccIsClang
|
GccLt46
|
CrossCompiling
|
Validating
|
SupportsPackageKey
|
SolarisBrokenShld
|
SplitObjectsBroken
|
GhcUnregisterised
-- TODO: Give the warning *only once* per key
test
::
Flag
->
Action
Bool
test
flag
=
do
(
key
,
defaultValue
)
<-
return
$
case
flag
of
LaxDeps
->
(
"lax-dependencies"
,
False
)
DynamicGhcPrograms
->
(
"dynamic-ghc-programs"
,
False
)
GccIsClang
->
(
"gcc-is-clang"
,
False
)
GccLt46
->
(
"gcc-lt-46"
,
False
)
CrossCompiling
->
(
"cross-compiling"
,
False
)
Validating
->
(
"validating"
,
False
)
SupportsPackageKey
->
(
"supports-package-key"
,
False
)
SolarisBrokenShld
->
(
"solaris-broken-shld"
,
False
)
SplitObjectsBroken
->
(
"split-objects-broken"
,
False
)
GhcUnregisterised
->
(
"ghc-unregisterised"
,
False
)
let
defaultString
=
if
defaultValue
then
"YES"
else
"NO"
value
<-
askConfigWithDefault
key
$
-- TODO: warn just once
do
putColoured
Red
$
"
\n
Flag '"
++
key
++
"' not set in configuration files. "
++
"Proceeding with default value '"
++
defaultString
++
"'.
\n
"
return
defaultString
flag
::
Flag
->
Action
Bool
flag
f
=
do
key
<-
return
$
case
f
of
GccIsClang
->
"gcc-is-clang"
GccLt46
->
"gcc-lt-46"
CrossCompiling
->
"cross-compiling"
SupportsPackageKey
->
"supports-package-key"
SolarisBrokenShld
->
"solaris-broken-shld"
SplitObjectsBroken
->
"split-objects-broken"
GhcUnregisterised
->
"ghc-unregisterised"
value
<-
askConfigWithDefault
key
.
redError
$
"
\n
Flag '"
++
key
++
"' not set in configuration files."
unless
(
value
==
"YES"
||
value
==
"NO"
)
.
redError
$
"
\n
Flag '"
++
key
++
"' is set to '"
++
value
++
"' instead of 'YES' or 'NO'."
return
$
value
==
"YES"
supportsPackageKey
::
Action
Bool
supportsPackageKey
=
flag
SupportsPackageKey
crossCompiling
::
Action
Bool
crossCompiling
=
flag
CrossCompiling
gccIsClang
::
Action
Bool
gccIsClang
=
flag
GccIsClang
gccLt46
::
Action
Bool
gccLt46
=
flag
GccLt46
platformSupportsSharedLibs
::
Action
Bool
platformSupportsSharedLibs
=
do
badPlatform
<-
targetPlatforms
[
"powerpc-unknown-linux"
,
"x86_64-unknown-mingw32"
,
"i386-unknown-mingw32"
]
solaris
<-
targetPlatform
"i386-unknown-solaris2"
solarisBroken
<-
flag
SolarisBrokenShld
return
$
not
(
badPlatform
||
solaris
&&
solarisBroken
)
src/Oracles/Setting.hs
View file @
b2533979
module
Oracles.Setting
(
Setting
(
..
),
SettingList
(
..
),
setting
,
settingList
,
windowsHost
targetPlatform
,
targetPlatforms
,
targetOs
,
targetOss
,
notTargetOs
,
targetArchs
,
windowsHost
,
notWindowsHost
,
ghcWithInterpreter
)
where
import
Stage
...
...
@@ -53,7 +54,42 @@ settingList key = fmap words $ askConfig $ case key of
GmpIncludeDirs
->
"gmp-include-dirs"
GmpLibDirs
->
"gmp-lib-dirs"
matchSetting
::
Setting
->
[
String
]
->
Action
Bool
matchSetting
key
values
=
do
value
<-
setting
key
return
$
value
`
elem
`
values
targetPlatforms
::
[
String
]
->
Action
Bool
targetPlatforms
=
matchSetting
TargetPlatformFull
targetPlatform
::
String
->
Action
Bool
targetPlatform
s
=
targetPlatforms
[
s
]
targetOss
::
[
String
]
->
Action
Bool
targetOss
=
matchSetting
TargetOs
targetOs
::
String
->
Action
Bool
targetOs
s
=
targetOss
[
s
]
notTargetOs
::
String
->
Action
Bool
notTargetOs
=
fmap
not
.
targetOs
targetArchs
::
[
String
]
->
Action
Bool
targetArchs
=
matchSetting
TargetArch
windowsHost
::
Action
Bool
windowsHost
=
do
hostOsCpp
<-
setting
HostOsCpp
return
$
hostOsCpp
`
elem
`
[
"mingw32"
,
"cygwin32"
]
notWindowsHost
::
Action
Bool
notWindowsHost
=
fmap
not
windowsHost
ghcWithInterpreter
::
Action
Bool
ghcWithInterpreter
=
do
goodOs
<-
targetOss
[
"mingw32"
,
"cygwin32"
,
"linux"
,
"solaris2"
,
"freebsd"
,
"dragonfly"
,
"netbsd"
,
"openbsd"
,
"darwin"
,
"kfreebsdgnu"
]
goodArch
<-
targetArchs
[
"i386"
,
"x86_64"
,
"powerpc"
,
"sparc"
,
"sparc64"
,
"arm"
]
return
$
goodOs
&&
goodArch
src/Rules/Actions.hs
View file @
b2533979
module
Rules.Actions
(
build
,
buildWhen
,
run
,
verboseRun
,
build
,
buildWhen
,
run
,
verboseRun
)
where
import
Util
import
Builder
import
Expression
import
Settings.Args
import
Settings.Util
import
Oracles.ArgsHash
import
Development.Shake
...
...
@@ -15,8 +16,6 @@ import Development.Shake
build
::
FullTarget
->
Action
()
build
target
=
do
argList
<-
interpret
target
args
putColoured
Green
(
show
target
)
putColoured
Green
(
show
argList
)
-- The line below forces the rule to be rerun if the args hash has changed
argsHash
<-
askArgsHash
target
run
(
getBuilder
target
)
argList
...
...
src/Settings/GhcCabal.hs
View file @
b2533979
...
...
@@ -10,6 +10,8 @@ import Util
import
Switches
import
Expression
import
Oracles.Base
import
Oracles.Flag
import
Oracles.Setting
import
Settings.User
import
Settings.Ways
import
Settings.Util
...
...
@@ -30,7 +32,7 @@ cabalArgs = builder GhcCabal ? do
,
with
$
GhcPkg
stage
,
stage0
?
bootPackageDbArgs
,
libraryArgs
,
configKeyNonEmpty
"hscolour"
?
with
HsColour
,
with
HsColour
,
configureArgs
,
stage0
?
packageConstraints
,
with
$
Gcc
stage
...
...
@@ -42,13 +44,12 @@ cabalArgs = builder GhcCabal ? do
-- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
libraryArgs
::
Args
libraryArgs
=
do
ways
<-
fromDiffExpr
Settings
.
Ways
.
ways
ghcInterpreter
<-
ghcWithInterpreter
dynamicPrograms
<-
dynamicGhcPrograms
ways
<-
fromDiffExpr
Settings
.
Ways
.
ways
ghcInterpreter
<-
lift
$
ghcWithInterpreter
append
[
if
vanilla
`
elem
`
ways
then
"--enable-library-vanilla"
else
"--disable-library-vanilla"
,
if
vanilla
`
elem
`
ways
&&
ghcInterpreter
&&
not
dynamicPrograms
,
if
vanilla
`
elem
`
ways
&&
ghcInterpreter
&&
not
dynamic
Ghc
Programs
then
"--enable-library-for-ghci"
else
"--disable-library-for-ghci"
,
if
profiling
`
elem
`
ways
...
...
@@ -151,7 +152,7 @@ withBuilderKey builder = case builder of
-- Expression 'with Gcc' appends "--with-gcc=/path/to/gcc" and needs Gcc.
with
::
Builder
->
Args
with
builder
=
do
with
builder
=
specified
builder
?
do
path
<-
lift
$
builderPath
builder
lift
$
needBuilder
builder
append
[
withBuilderKey
builder
++
path
]
src/Settings/Packages.hs
View file @
b2533979
...
...
@@ -6,6 +6,7 @@ module Settings.Packages (
import
Package
import
Switches
import
Expression
import
Oracles.Setting
import
Settings.User
import
Settings.Default
...
...
src/Settings/User.hs
View file @
b2533979
...
...
@@ -2,7 +2,7 @@ module Settings.User (
module
Settings
.
Default
,
userArgs
,
userPackages
,
userWays
,
userTargetDirectory
,
userKnownPackages
,
integerLibrary
,
buildHaddock
,
validating
buildHaddock
,
validating
,
dynamicGhcPrograms
,
laxDependencies
)
where
import
Stage
...
...
@@ -35,10 +35,18 @@ userTargetDirectory = defaultTargetDirectory
integerLibrary
::
Package
integerLibrary
=
integerGmp2
-- User-defined predicates
-- TODO: migrate more predicates here from configuration files
-- User-defined flags. Note the following type semantics:
-- * Bool: a plain Boolean flag whose value is known at compile time
-- * Action Bool: a flag whose value can depend on the build environment
-- * Predicate: a flag depending on the build environment and the current target
validating
::
Bool
validating
=
False
dynamicGhcPrograms
::
Bool
dynamicGhcPrograms
=
False
laxDependencies
::
Bool
laxDependencies
=
False
buildHaddock
::
Predicate
buildHaddock
=
return
True
validating
::
Predicate
validating
=
return
False
src/Settings/Util.hs
View file @
b2533979
...
...
@@ -3,6 +3,7 @@ module Settings.Util (
arg
,
argPath
,
argM
,
argConfig
,
argStagedConfig
,
argConfigList
,
argStagedConfigList
,
appendCcArgs
,
needBuilder
-- argBuilderPath, argStagedBuilderPath,
-- argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
-- argIncludeDirs, argDepIncludeDirs,
...
...
@@ -14,6 +15,7 @@ module Settings.Util (
import
Util
import
Stage
import
Builder
import
Settings.User
import
Oracles.Base
import
Expression
...
...
@@ -55,6 +57,20 @@ appendCcArgs xs = do
,
builder
GhcCabal
?
appendSub
"--configure-option=CFLAGS"
xs
,
builder
GhcCabal
?
appendSub
"--gcc-options"
xs
]
-- Make sure a builder exists on the given path and rebuild it if out of date.
-- If laxDependencies is true (Settings/User.hs) then we do not rebuild GHC
-- even if it is out of date (can save a lot of build time when changing GHC).
needBuilder
::
Builder
->
Action
()
needBuilder
ghc
@
(
Ghc
stage
)
=
do
path
<-
builderPath
ghc
if
laxDependencies
then
orderOnly
[
path
]
else
need
[
path
]
needBuilder
builder
=
do
path
<-
builderPath
builder
need
[
path
]
-- packageData :: Arity -> String -> Args
-- packageData arity key =
-- return $ EnvironmentParameter $ PackageData arity key Nothing Nothing
...
...
src/Settings/Ways.hs
View file @
b2533979
...
...
@@ -6,6 +6,7 @@ import Way
import
Stage
import
Switches
import
Expression
import
Oracles.Flag
import
Settings.User
-- Combining default ways with user modifications
...
...
src/Switches.hs
View file @
b2533979
module
Switches
(
notStage
,
stage0
,
stage1
,
stage2
,
configKeyYes
,
configKeyNo
,
configKeyNonEmpty
,
supportsPackageKey
,
targetPlatforms
,
targetPlatform
,
targetOss
,
targetOs
,
notTargetOs
,
targetArchs
,
dynamicGhcPrograms
,
ghcWithInterpreter
,
platformSupportsSharedLibs
,
crossCompiling
,
gccIsClang
,
gccLt46
,
windowsHost
,
notWindowsHost
,
registerPackage
registerPackage
,
splitObjects
)
where
import
Stage
import
Oracles.Flag
import
Oracles.Setting
import
Expression
-- Derived predicates
notStage
::
Stage
->
Predicate
notStage
=
liftM
not
.
stage
notStage
=
not
P
.
stage
stage0
::
Predicate
stage0
=
stage
Stage0
...
...
@@ -25,84 +21,17 @@ stage1 = stage Stage1
stage2
::
Predicate
stage2
=
stage
Stage2
configKeyYes
::
String
->
Predicate
configKeyYes
key
=
configKeyValue
key
"YES"
configKeyNo
::
String
->
Predicate
configKeyNo
key
=
configKeyValue
key
"NO"
configKeyNonEmpty
::
String
->
Predicate
configKeyNonEmpty
key
=
liftM
not
$
configKeyValue
key
""
-- Predicates based on configuration files
supportsPackageKey
::
Predicate
supportsPackageKey
=
configKeyYes
"supports-package-key"
targetPlatforms
::
[
String
]
->
Predicate
targetPlatforms
=
configKeyValues
"target-platform-full"
targetPlatform
::
String
->
Predicate
targetPlatform
s
=
targetPlatforms
[
s
]
targetOss
::
[
String
]
->
Predicate
targetOss
=
configKeyValues
"target-os"
targetOs
::
String
->
Predicate
targetOs
s
=
targetOss
[
s
]
notTargetOs
::
String
->
Predicate
notTargetOs
=
liftM
not
.
targetOs
targetArchs
::
[
String
]
->
Predicate
targetArchs
=
configKeyValues
"target-arch"
platformSupportsSharedLibs
::
Predicate
platformSupportsSharedLibs
=
do
badPlatform
<-
targetPlatforms
[
"powerpc-unknown-linux"
,
"x86_64-unknown-mingw32"
,
"i386-unknown-mingw32"
]
solaris
<-
targetPlatform
"i386-unknown-solaris2"
solarisBroken
<-
configKeyYes
"solaris-broken-shld"
return
$
not
(
badPlatform
||
solaris
&&
solarisBroken
)
dynamicGhcPrograms
::
Predicate
dynamicGhcPrograms
=
configKeyYes
"dynamic-ghc-programs"
ghcWithInterpreter
::
Predicate
ghcWithInterpreter
=
do
goodOs
<-
targetOss
[
"mingw32"
,
"cygwin32"
,
"linux"
,
"solaris2"
,
"freebsd"
,
"dragonfly"
,
"netbsd"
,
"openbsd"
,
"darwin"
,
"kfreebsdgnu"
]
goodArch
<-
targetArchs
[
"i386"
,
"x86_64"
,
"powerpc"
,
"sparc"
,
"sparc64"
,
"arm"
]
return
$
goodOs
&&
goodArch
crossCompiling
::
Predicate
crossCompiling
=
configKeyYes
"cross-compiling"
gccIsClang
::
Predicate
gccIsClang
=
configKeyYes
"gcc-is-clang"
gccLt46
::
Predicate
gccLt46
=
configKeyYes
"gcc-lt-46"
windowsHost
::
Predicate
windowsHost
=
configKeyValues
"host-os-cpp"
[
"mingw32"
,
"cygwin32"
]
notWindowsHost
::
Predicate
notWindowsHost
=
liftM
not
windowsHost
-- TODO: Actually, we don't register compiler in some circumstances -- fix.
registerPackage
::
Predicate
registerPackage
=
return
True
--
splitObjects ::
Stage -> Condition
--
splitObjects
stage
= do
-- arch <- showArg TargetArch
--
os <- showArg TargetOs
--
not
SplitObjectsBroken && not
GhcUnregisterised
--
&& s
tage
== Stage1
--
&& arch `elem` ["i386", "x86_64", "powerpc", "sparc"]
--
&& os `elem` ["mingw32", "cyg
win
32
", "
linux", "darwin",
--
"solaris2", "freebsd"
, "dragonfly", "netbsd",
--
"openbsd"]
splitObjects
::
Predicate
splitObjects
=
do
stage
<-
asks
getStage
notBroken
<-
notP
.
flag
$
SplitObjectsBroken
not
GhcUnreg
<-
notP
.
flag
$
GhcUnregisterised
goodArch
<-
lift
$
ta
r
ge
tArchs
[
"i386"
,
"x86_64"
,
"powerpc"
,
"sparc"
]
goodOs
<-
lift
$
targetOss
[
"mingw32"
,
"cygwin32"
,
"linux"
,
"dar
win"
,
"
solaris2"
,
"freebsd"
,
"dragonfly"
,
"netbsd"
,
"openbsd"
]
return
$
notBroken
&&
notGhcUnreg
&&
stage
==
Stage1
&&
goodArch
&&
goodOs
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a 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