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
5dd20f0d
Commit
5dd20f0d
authored
Aug 07, 2017
by
Andrey Mokhov
Browse files
Minor revision
parent
e37a5f77
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/Expression.hs
View file @
5dd20f0d
...
...
@@ -7,7 +7,7 @@ module Expression (
-- ** Predicates
(
?
),
stage
,
stage0
,
stage1
,
stage2
,
notStage0
,
package
,
notPackage
,
input
,
inputs
,
output
,
outputs
,
way
,
libraryPackage
,
libraryPackage
,
way
,
input
,
inputs
,
output
,
outputs
,
-- ** Evaluation
interpret
,
interpretInContext
,
...
...
@@ -17,7 +17,7 @@ module Expression (
-- * Convenient accessors
getContext
,
getStage
,
getPackage
,
getBuilder
,
getOutputs
,
getInputs
,
getWay
,
getInput
,
getOutput
,
getSetting
,
getSettingList
,
getStagedSettingList
,
getFlag
,
getInput
,
getOutput
,
getSetting
,
getSettingList
,
getStagedSettingList
,
-- * Re-exports
module
Data
.
Semigroup
,
...
...
@@ -40,7 +40,6 @@ import Stage
import
Target
hiding
(
builder
,
inputs
,
outputs
)
import
Way
import
Oracles.Config.Flag
import
Oracles.Config.Setting
-- | @Expr a@ is a computation that produces a value of type @Action a@ and can
...
...
@@ -55,20 +54,18 @@ type Args = H.Args Context Builder
type
Packages
=
Expr
[
Package
]
type
Ways
=
Expr
[
Way
]
-- Basic operations on expressions:
-- | Get a configuration setting.
getSetting
::
Setting
->
Expr
String
getSetting
=
expr
.
setting
getSettingList
::
SettingList
->
Expr
[
String
]
-- | Get a list of configuration settings.
getSettingList
::
SettingList
->
Args
getSettingList
=
expr
.
settingList
getStagedSettingList
::
(
Stage
->
SettingList
)
->
Expr
[
String
]
-- | Get a list of configuration settings for the current stage.
getStagedSettingList
::
(
Stage
->
SettingList
)
->
Args
getStagedSettingList
f
=
getSettingList
.
f
=<<
getStage
getFlag
::
Flag
->
Predicate
getFlag
=
expr
.
flag
-- | Is the build currently in the provided stage?
stage
::
Stage
->
Predicate
stage
s
=
(
s
==
)
<$>
getStage
...
...
src/Rules/Generate.hs
View file @
5dd20f0d
...
...
@@ -211,7 +211,7 @@ generateGhcPlatformH = do
targetArch
<-
getSetting
TargetArch
targetOs
<-
getSetting
TargetOs
targetVendor
<-
getSetting
TargetVendor
ghcUnreg
<-
getF
lag
GhcUnregisterised
ghcUnreg
<-
expr
$
f
lag
GhcUnregisterised
return
.
unlines
$
[
"#ifndef __GHCPLATFORM_H__"
,
"#define __GHCPLATFORM_H__"
...
...
@@ -275,7 +275,7 @@ generateConfigHs = do
cGHC_UNLIT_PGM
<-
fmap
takeFileName
$
getBuilderPath
Unlit
cLibFFI
<-
expr
useLibFFIForAdjustors
rtsWays
<-
getRtsWays
cGhcRtsWithLibdw
<-
getF
lag
WithLibdw
cGhcRtsWithLibdw
<-
expr
$
f
lag
WithLibdw
let
cGhcRTSWays
=
unwords
$
map
show
rtsWays
return
$
unlines
[
"{-# LANGUAGE CPP #-}"
...
...
@@ -349,7 +349,7 @@ generateGhcAutoconfH = do
trackGenerateHs
configHContents
<-
expr
$
map
undefinePackage
<$>
readFileLines
configH
tablesNextToCode
<-
expr
ghcEnableTablesNextToCode
ghcUnreg
<-
getF
lag
GhcUnregisterised
ghcUnreg
<-
expr
$
f
lag
GhcUnregisterised
ccLlvmBackend
<-
getSetting
CcLlvmBackend
ccClangBackend
<-
getSetting
CcClangBackend
return
.
unlines
$
...
...
src/Settings.hs
View file @
5dd20f0d
module
Settings
(
getArgs
,
getPackages
,
getLibraryWays
,
getRtsWays
,
flavour
,
knownPackages
,
findKnownPackage
,
getPkgData
,
getPkgDataList
,
isLibrary
,
getPackagePath
,
getContextDirectory
,
getBuildPath
,
stagePackages
,
builderPath
,
findKnownPackage
,
getPkgData
,
getPkgDataList
,
isLibrary
,
getBuildPath
,
stagePackages
,
builderPath
,
getBuilderPath
,
isSpecified
,
latestBuildStage
,
programPath
,
programContext
,
integerLibraryName
,
destDir
,
pkgConfInstallPath
,
stage1Only
)
where
...
...
@@ -25,27 +25,21 @@ import Settings.Flavours.Quickest
import
Settings.Path
import
UserSettings
getArgs
::
Expr
[
String
]
getArgs
::
Args
getArgs
=
args
flavour
getLibraryWays
::
Expr
[
Way
]
getLibraryWays
::
Way
s
getLibraryWays
=
libraryWays
flavour
getRtsWays
::
Expr
[
Way
]
getRtsWays
::
Way
s
getRtsWays
=
rtsWays
flavour
getPackages
::
Expr
[
Package
]
getPackages
::
Package
s
getPackages
=
packages
flavour
stagePackages
::
Stage
->
Action
[
Package
]
stagePackages
stage
=
interpretInContext
(
stageContext
stage
)
getPackages
getPackagePath
::
Expr
FilePath
getPackagePath
=
pkgPath
<$>
getPackage
getContextDirectory
::
Expr
FilePath
getContextDirectory
=
stageDirectory
<$>
getStage
getBuildPath
::
Expr
FilePath
getBuildPath
=
buildPath
<$>
getContext
...
...
@@ -80,7 +74,7 @@ programContext stage pkg
knownPackages
::
[
Package
]
knownPackages
=
sort
$
defaultKnownPackages
++
userKnownPackages
-- TODO: Speed up?
-- TODO: Speed up?
Switch to Set?
-- Note: this is slow but we keep it simple as there are just ~50 packages
findKnownPackage
::
PackageName
->
Maybe
Package
findKnownPackage
name
=
find
(
\
pkg
->
pkgName
pkg
==
name
)
knownPackages
...
...
@@ -156,12 +150,12 @@ programPath context@Context {..} = do
pkgConfInstallPath
::
FilePath
pkgConfInstallPath
=
buildPath
(
vanillaContext
Stage0
rts
)
-/-
"package.conf.install"
--
| Stage1Only flag
--
TODO: Set this by cmdline
flag
s
--
TODO: Set this from command line
--
| Stage1Only
flag
.
stage1Only
::
Bool
stage1Only
=
defaultStage1Only
--
| Install's DESTDIR flag
--
TODO: Set this by cmdline flags
--
TODO: Set this from command line
--
| Install's DESTDIR setting.
destDir
::
FilePath
destDir
=
defaultDestDir
src/Settings/Builders/Ghc.hs
View file @
5dd20f0d
module
Settings.Builders.Ghc
(
ghcBuilderArgs
,
ghcMBuilderArgs
,
haddockGhcArgs
,
ghcCbuilderArgs
)
where
ghcBuilderArgs
,
ghcMBuilderArgs
,
haddockGhcArgs
,
ghcCbuilderArgs
)
where
import
Flavour
import
GHC
import
Settings.Builders.Common
ghcBuilderArgs
::
Args
...
...
@@ -18,6 +16,11 @@ ghcBuilderArgs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
,
getInputs
,
arg
"-o"
,
arg
=<<
getOutput
]
needTouchy
::
Expr
()
needTouchy
=
notStage0
?
do
maybePath
<-
expr
$
programPath
(
vanillaContext
Stage0
touchy
)
expr
.
whenJust
maybePath
$
\
path
->
need
[
path
]
ghcCbuilderArgs
::
Args
ghcCbuilderArgs
=
builder
(
Ghc
CompileCWithGhc
)
?
do
...
...
@@ -58,11 +61,6 @@ ghcLinkArgs = builder (Ghc LinkHs) ? do
,
pure
[
"-optl-l"
++
lib
|
lib
<-
libs
++
gmpLibs
]
,
pure
[
"-optl-L"
++
unifyPath
dir
|
dir
<-
libDirs
]
]
needTouchy
::
Expr
()
needTouchy
=
notStage0
?
do
maybePath
<-
expr
$
programPath
(
vanillaContext
Stage0
touchy
)
expr
.
whenJust
maybePath
$
\
path
->
need
[
path
]
splitObjectsArgs
::
Args
splitObjectsArgs
=
splitObjects
flavour
?
do
expr
$
need
[
ghcSplitPath
]
...
...
@@ -116,10 +114,10 @@ wayGhcArgs = do
-- FIXME: Get rid of to-be-deprecated -this-package-key.
packageGhcArgs
::
Args
packageGhcArgs
=
do
compId
<-
getPkgData
ComponentId
compId
<-
getPkgData
ComponentId
thisArg
<-
do
not0
<-
notStage0
unit
<-
getF
lag
SupportsThisUnitId
unit
<-
expr
$
f
lag
SupportsThisUnitId
return
$
if
not0
||
unit
then
"-this-unit-id "
else
"-this-package-key "
mconcat
[
arg
"-hide-all-packages"
,
arg
"-no-user-package-db"
...
...
src/Settings/Builders/GhcCabal.hs
View file @
5dd20f0d
...
...
@@ -14,7 +14,7 @@ ghcCabalBuilderArgs = builder GhcCabal ? do
context
<-
getContext
when
(
package
context
/=
deriveConstants
)
$
expr
(
need
inplaceLibCopyTargets
)
mconcat
[
arg
"configure"
,
arg
=<<
getPackage
Path
,
arg
=<<
pkgPath
<$>
getPackage
,
arg
$
top
-/-
buildPath
context
,
dll0Args
,
withStaged
$
Ghc
CompileHs
...
...
@@ -34,7 +34,7 @@ ghcCabalBuilderArgs = builder GhcCabal ? do
ghcCabalHsColourBuilderArgs
::
Args
ghcCabalHsColourBuilderArgs
=
builder
GhcCabalHsColour
?
do
path
<-
getPackage
Path
path
<-
pkgPath
<$>
getPackage
top
<-
expr
topDirectory
context
<-
getContext
pure
[
"hscolour"
,
path
,
top
-/-
buildPath
context
]
...
...
Write
Preview
Markdown
is supported
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