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
37262111
Commit
37262111
authored
Jul 15, 2015
by
Andrey Mokhov
Browse files
Rename Ways.hs => Way.hs and refactor it.
parent
9bde7d86
Changes
11
Hide whitespace changes
Inline
Side-by-side
src/Base.hs
View file @
37262111
...
...
@@ -27,10 +27,6 @@ data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum, Generic)
instance
Show
Stage
where
show
=
show
.
fromEnum
-- Instances for storing Target in the Shake database
instance
Binary
Stage
instance
Hashable
Stage
-- The returned string or list of strings is a part of an argument list
-- to be passed to a Builder
type
Arg
=
Action
String
...
...
@@ -73,3 +69,7 @@ concatArgs as bs = do
as'
<-
showArgs
as
bs'
<-
showArgs
bs
return
$
map
concat
$
sequence
[
as'
,
bs'
]
-- Instances for storing in the Shake database
instance
Binary
Stage
instance
Hashable
Stage
src/Builder.hs
View file @
37262111
...
...
@@ -87,6 +87,6 @@ needBuilder builder = do
path
<-
builderPath
builder
need
[
path
]
-- Instances for storing
Target
in the Shake database
-- Instances for storing in the Shake database
instance
Binary
Builder
instance
Hashable
Builder
src/Expression.hs
View file @
37262111
...
...
@@ -11,8 +11,8 @@ module Expression (
configKeyValue
,
configKeyValues
)
where
import
Way
import
Base
import
Ways
import
Builder
import
Package
import
Target
...
...
src/Package.hs
View file @
37262111
...
...
@@ -25,11 +25,6 @@ instance Eq Package where
instance
Ord
Package
where
compare
=
compare
`
on
`
pkgName
instance
Binary
Package
instance
Hashable
Package
where
hashWithSalt
salt
=
hashWithSalt
salt
.
show
-- TODO: check if unifyPath is actually needed
library
::
String
->
Package
library
name
=
...
...
@@ -40,3 +35,8 @@ topLevel name = Package name name (name <.> "cabal")
setCabal
::
Package
->
FilePath
->
Package
setCabal
pkg
cabalName
=
pkg
{
pkgCabal
=
cabalName
}
-- Instances for storing in the Shake database
instance
Binary
Package
instance
Hashable
Package
where
hashWithSalt
salt
=
hashWithSalt
salt
.
show
src/Rules/Data.hs
View file @
37262111
...
...
@@ -4,6 +4,7 @@ module Rules.Data (
cabalArgs
,
ghcPkgArgs
,
buildPackageData
)
where
import
Way
import
Base
import
Package
import
Builder
...
...
@@ -14,7 +15,6 @@ import Settings.GhcCabal
import
Settings.TargetDirectory
import
Rules.Actions
import
Util
import
Ways
-- Build package-data.mk by using GhcCabal to process pkgCabal file
buildPackageData
::
StagePackageTarget
->
Rules
()
...
...
src/Settings/GhcCabal.hs
View file @
37262111
...
...
@@ -2,10 +2,10 @@ module Settings.GhcCabal (
cabalArgs
,
bootPackageDbArgs
,
customPackageArgs
)
where
import
Way
import
Base
import
Builder
import
Package
import
Ways
import
Util
import
Oracles.Base
import
Switches
...
...
src/Settings/Util.hs
View file @
37262111
...
...
@@ -102,3 +102,18 @@ appendCcArgs xs = do
-- -- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
-- argPrefixPath :: String -> Args -> Args
-- argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
-- TODO: do '-ticky' in all debug ways?
-- wayHcArgs :: Way -> Args
-- wayHcArgs (Way _ units) = args
-- [ if (Dynamic `elem` units)
-- then args ["-fPIC", "-dynamic"]
-- else arg "-static"
-- , when (Threaded `elem` units) $ arg "-optc-DTHREADED_RTS"
-- , when (Debug `elem` units) $ arg "-optc-DDEBUG"
-- , when (Profiling `elem` units) $ arg "-prof"
-- , when (Logging `elem` units) $ arg "-eventlog"
-- , when (Parallel `elem` units) $ arg "-parallel"
-- , when (GranSim `elem` units) $ arg "-gransim"
-- , when (units == [Debug] || units == [Debug, Dynamic]) $
-- args ["-ticky", "-DTICKY_TICKY"] ]
src/Settings/Ways.hs
View file @
37262111
...
...
@@ -2,8 +2,8 @@ module Settings.Ways (
ways
)
where
import
Way
import
Base
import
Ways
import
Switches
import
Expression
import
Settings.User
...
...
src/Target.hs
View file @
37262111
...
...
@@ -4,8 +4,8 @@ module Target (
stageTarget
,
stagePackageTarget
,
fullTarget
)
where
import
Way
import
Base
import
Ways
import
Package
import
Builder
import
GHC.Generics
...
...
@@ -70,7 +70,7 @@ instance Show FullTarget where
++
" ("
++
show
(
getBuilder
target
)
++
", "
++
show
(
getWay
target
)
++
")"
-- Instances for storing
FullTarget
in the Shake database
-- Instances for storing in the Shake database
instance
Binary
FullTarget
instance
NFData
FullTarget
instance
Hashable
FullTarget
src/Way.hs
0 → 100644
View file @
37262111
module
Way
(
-- TODO: rename to "Way"?
WayUnit
(
..
),
Way
,
wayFromUnits
,
wayUnit
,
vanilla
,
profiling
,
logging
,
parallel
,
granSim
,
threaded
,
threadedProfiling
,
threadedLogging
,
debug
,
debugProfiling
,
threadedDebug
,
threadedDebugProfiling
,
dynamic
,
profilingDynamic
,
threadedProfilingDynamic
,
threadedDynamic
,
threadedDebugDynamic
,
debugDynamic
,
loggingDynamic
,
threadedLoggingDynamic
,
wayPrefix
,
hisuf
,
osuf
,
hcsuf
,
obootsuf
,
ssuf
,
libsuf
,
detectWay
)
where
import
Base
import
Util
import
Data.IntSet
(
IntSet
)
import
qualified
Data.IntSet
as
IntSet
import
Oracles.Option
import
Development.Shake.Classes
data
WayUnit
=
Threaded
|
Debug
|
Profiling
|
Logging
|
Dynamic
|
Parallel
|
GranSim
deriving
Enum
instance
Show
WayUnit
where
show
unit
=
case
unit
of
Threaded
->
"thr"
Debug
->
"debug"
Profiling
->
"p"
Logging
->
"l"
Dynamic
->
"dyn"
Parallel
->
"mp"
GranSim
->
"gm"
instance
Read
WayUnit
where
readsPrec
_
s
=
[(
unit
,
""
)
|
unit
<-
[
Threaded
..
],
show
unit
==
s
]
newtype
Way
=
Way
IntSet
wayFromUnits
::
[
WayUnit
]
->
Way
wayFromUnits
=
Way
.
IntSet
.
fromList
.
map
fromEnum
wayToUnits
::
Way
->
[
WayUnit
]
wayToUnits
(
Way
set
)
=
map
toEnum
.
IntSet
.
elems
$
set
wayUnit
::
WayUnit
->
Way
->
Bool
wayUnit
unit
(
Way
set
)
=
fromEnum
unit
`
IntSet
.
member
`
set
instance
Show
Way
where
show
way
=
if
null
tag
then
"v"
else
tag
where
tag
=
intercalate
"_"
.
map
show
.
wayToUnits
$
way
instance
Read
Way
where
readsPrec
_
s
=
if
s
==
"v"
then
[(
vanilla
,
""
)]
else
[(
wayFromUnits
.
map
read
.
words
.
replaceEq
'_'
' '
$
s
,
""
)]
instance
Eq
Way
where
Way
a
==
Way
b
=
a
==
b
vanilla
=
wayFromUnits
[]
profiling
=
wayFromUnits
[
Profiling
]
logging
=
wayFromUnits
[
Logging
]
parallel
=
wayFromUnits
[
Parallel
]
granSim
=
wayFromUnits
[
GranSim
]
-- RTS only ways
-- TODO: do we need to define *only* these? Shall we generalise/simplify?
threaded
=
wayFromUnits
[
Threaded
]
threadedProfiling
=
wayFromUnits
[
Threaded
,
Profiling
]
threadedLogging
=
wayFromUnits
[
Threaded
,
Logging
]
debug
=
wayFromUnits
[
Debug
]
debugProfiling
=
wayFromUnits
[
Debug
,
Profiling
]
threadedDebug
=
wayFromUnits
[
Threaded
,
Debug
]
threadedDebugProfiling
=
wayFromUnits
[
Threaded
,
Debug
,
Profiling
]
dynamic
=
wayFromUnits
[
Dynamic
]
profilingDynamic
=
wayFromUnits
[
Profiling
,
Dynamic
]
threadedProfilingDynamic
=
wayFromUnits
[
Threaded
,
Profiling
,
Dynamic
]
threadedDynamic
=
wayFromUnits
[
Threaded
,
Dynamic
]
threadedDebugDynamic
=
wayFromUnits
[
Threaded
,
Debug
,
Dynamic
]
debugDynamic
=
wayFromUnits
[
Debug
,
Dynamic
]
loggingDynamic
=
wayFromUnits
[
Logging
,
Dynamic
]
threadedLoggingDynamic
=
wayFromUnits
[
Threaded
,
Logging
,
Dynamic
]
wayPrefix
::
Way
->
String
wayPrefix
way
|
way
==
vanilla
=
""
|
otherwise
=
show
way
++
"_"
hisuf
,
osuf
,
hcsuf
,
obootsuf
,
ssuf
::
Way
->
String
osuf
=
(
++
"o"
)
.
wayPrefix
ssuf
=
(
++
"s"
)
.
wayPrefix
hisuf
=
(
++
"hi"
)
.
wayPrefix
hcsuf
=
(
++
"hc"
)
.
wayPrefix
obootsuf
=
(
++
"o-boot"
)
.
wayPrefix
-- Note: in the previous build system libsuf was mysteriously different
-- from other suffixes. For example, in the profiling way it used to be
-- "_p.a" instead of ".p_a" which is how other suffixes work. I decided
-- to make all suffixes consistent: ".way_extension".
-- TODO: find out why we need version number in the dynamic suffix
-- The current theory: dynamic libraries are eventually placed in a single
-- giant directory in the load path of the dynamic linker, and hence we must
-- distinguish different versions of GHC. In contrast static libraries live
-- in their own per-package directory and hence do not need a unique filename.
-- We also need to respect the system's dynamic extension, e.g. .dll or .so.
libsuf
::
Way
->
Action
String
libsuf
way
@
(
Way
set
)
=
if
(
not
.
wayUnit
Dynamic
$
way
)
then
return
$
wayPrefix
way
++
"a"
-- e.g., p_a
else
do
extension
<-
showArg
DynamicExtension
-- e.g., .dll or .so
version
<-
showArg
ProjectVersion
-- e.g., 7.11.20141222
let
prefix
=
wayPrefix
.
Way
.
IntSet
.
delete
(
fromEnum
Dynamic
)
$
set
-- e.g., p_ghc7.11.20141222.dll (the result)
return
$
prefix
++
"ghc"
++
version
++
extension
-- Detect way from a given file extension. Fails if there is no match.
detectWay
::
FilePath
->
Way
detectWay
extension
=
read
prefix
where
prefix
=
dropWhileEnd
(
==
'_'
)
.
dropWhileEnd
(
/=
'_'
)
$
extension
-- Instances for storing in the Shake database
instance
Binary
Way
where
put
=
put
.
show
get
=
read
<$>
get
instance
Hashable
Way
where
hashWithSalt
salt
=
hashWithSalt
salt
.
show
src/Ways.hs
deleted
100644 → 0
View file @
9bde7d86
{-# LANGUAGE DeriveGeneric #-}
module
Ways
(
-- TODO: rename to "Way"?
WayUnit
(
..
),
Way
,
tag
,
allWays
,
vanilla
,
profiling
,
logging
,
parallel
,
granSim
,
threaded
,
threadedProfiling
,
threadedLogging
,
debug
,
debugProfiling
,
threadedDebug
,
threadedDebugProfiling
,
dynamic
,
profilingDynamic
,
threadedProfilingDynamic
,
threadedDynamic
,
threadedDebugDynamic
,
debugDynamic
,
loggingDynamic
,
threadedLoggingDynamic
,
wayPrefix
,
hisuf
,
osuf
,
hcsuf
,
obootsuf
,
ssuf
,
libsuf
,
detectWay
)
where
import
Base
import
Oracles.Option
import
GHC.Generics
import
Development.Shake.Classes
data
WayUnit
=
Profiling
|
Logging
|
Parallel
|
GranSim
|
Threaded
|
Debug
|
Dynamic
deriving
(
Eq
,
Generic
)
-- TODO: think about Booleans instead of a list of ways.
data
Way
=
Way
{
tag
::
String
,
-- e.g., "thr_p"
units
::
[
WayUnit
]
-- e.g., [Threaded, Profiling]
}
deriving
Generic
instance
Show
Way
where
show
=
tag
instance
Binary
WayUnit
instance
Binary
Way
instance
Hashable
Way
where
hashWithSalt
salt
=
hashWithSalt
salt
.
show
instance
Eq
Way
where
-- The tag is fully determined by the units
a
==
b
=
units
a
==
units
b
vanilla
=
Way
"v"
[]
profiling
=
Way
"p"
[
Profiling
]
logging
=
Way
"l"
[
Logging
]
parallel
=
Way
"mp"
[
Parallel
]
granSim
=
Way
"gm"
[
GranSim
]
isVanilla
::
Way
->
Bool
isVanilla
=
null
.
units
-- RTS only ways
-- TODO: do we need to define *only* these? Shall we generalise/simplify?
threaded
=
Way
"thr"
[
Threaded
]
threadedProfiling
=
Way
"thr_p"
[
Threaded
,
Profiling
]
threadedLogging
=
Way
"thr_l"
[
Threaded
,
Logging
]
debug
=
Way
"debug"
[
Debug
]
debugProfiling
=
Way
"debug_p"
[
Debug
,
Profiling
]
threadedDebug
=
Way
"thr_debug"
[
Threaded
,
Debug
]
threadedDebugProfiling
=
Way
"thr_debug_p"
[
Threaded
,
Debug
,
Profiling
]
dynamic
=
Way
"dyn"
[
Dynamic
]
profilingDynamic
=
Way
"p_dyn"
[
Profiling
,
Dynamic
]
threadedProfilingDynamic
=
Way
"thr_p_dyn"
[
Threaded
,
Profiling
,
Dynamic
]
threadedDynamic
=
Way
"thr_dyn"
[
Threaded
,
Dynamic
]
threadedDebugDynamic
=
Way
"thr_debug_dyn"
[
Threaded
,
Debug
,
Dynamic
]
debugDynamic
=
Way
"debug_dyn"
[
Debug
,
Dynamic
]
loggingDynamic
=
Way
"l_dyn"
[
Logging
,
Dynamic
]
threadedLoggingDynamic
=
Way
"thr_l_dyn"
[
Threaded
,
Logging
,
Dynamic
]
allWays
=
[
vanilla
,
profiling
,
logging
,
parallel
,
granSim
,
threaded
,
threadedProfiling
,
threadedLogging
,
debug
,
debugProfiling
,
threadedDebug
,
threadedDebugProfiling
,
dynamic
,
profilingDynamic
,
threadedProfilingDynamic
,
threadedDynamic
,
threadedDebugDynamic
,
debugDynamic
,
loggingDynamic
,
threadedLoggingDynamic
]
-- defaultWays :: Stage -> Action [Way]
-- defaultWays stage = do
-- sharedLibs <- platformSupportsSharedLibs
-- return $ [vanilla]
-- ++ [profiling | stage /= Stage0]
-- ++ [dynamic | sharedLibs ]
-- TODO: do '-ticky' in all debug ways?
-- wayHcArgs :: Way -> Args
-- wayHcArgs (Way _ units) = args
-- [ if (Dynamic `elem` units)
-- then args ["-fPIC", "-dynamic"]
-- else arg "-static"
-- , when (Threaded `elem` units) $ arg "-optc-DTHREADED_RTS"
-- , when (Debug `elem` units) $ arg "-optc-DDEBUG"
-- , when (Profiling `elem` units) $ arg "-prof"
-- , when (Logging `elem` units) $ arg "-eventlog"
-- , when (Parallel `elem` units) $ arg "-parallel"
-- , when (GranSim `elem` units) $ arg "-gransim"
-- , when (units == [Debug] || units == [Debug, Dynamic]) $
-- args ["-ticky", "-DTICKY_TICKY"] ]
wayPrefix
::
Way
->
String
wayPrefix
way
|
isVanilla
way
=
""
|
otherwise
=
tag
way
++
"_"
hisuf
,
osuf
,
hcsuf
,
obootsuf
,
ssuf
::
Way
->
String
osuf
=
(
++
"o"
)
.
wayPrefix
ssuf
=
(
++
"s"
)
.
wayPrefix
hisuf
=
(
++
"hi"
)
.
wayPrefix
hcsuf
=
(
++
"hc"
)
.
wayPrefix
obootsuf
=
(
++
"o-boot"
)
.
wayPrefix
-- Note: in the previous build system libsuf was mysteriously different
-- from other suffixes. For example, in the profiling way it used to be
-- "_p.a" instead of ".p_a" which is how other suffixes work. I decided
-- to make all suffixes consistent: ".way_extension".
-- TODO: find out why we need version number in the dynamic suffix
-- The current theory: dynamic libraries are eventually placed in a single
-- giant directory in the load path of the dynamic linker, and hence we must
-- distinguish different versions of GHC. In contrast static libraries live
-- in their own per-package directory and hence do not need a unique filename.
-- We also need to respect the system's dynamic extension, e.g. .dll or .so.
-- TODO: fix the extension
libsuf
::
Way
->
Action
String
libsuf
way
|
Dynamic
`
notElem
`
units
way
=
return
$
wayPrefix
way
++
"a"
-- e.g., p_a
|
otherwise
=
do
extension
<-
showArg
DynamicExtension
-- e.g., .dll or .so
version
<-
showArg
ProjectVersion
-- e.g., 7.11.20141222
let
suffix
=
wayPrefix
$
dropDynamic
way
-- e.g., p_ghc7.11.20141222.dll (the result)
return
$
suffix
++
"ghc"
++
version
++
extension
-- TODO: This may be slow -- optimise if overhead is significant.
dropDynamic
::
Way
->
Way
dropDynamic
way
|
way
==
dynamic
=
vanilla
|
way
==
profilingDynamic
=
profiling
|
way
==
threadedProfilingDynamic
=
threadedProfiling
|
way
==
threadedDynamic
=
threaded
|
way
==
threadedDebugDynamic
=
threadedDebug
|
way
==
debugDynamic
=
debug
|
way
==
loggingDynamic
=
logging
|
way
==
threadedLoggingDynamic
=
threadedLogging
|
otherwise
=
way
-- Detect way from a given extension. Fail if the result is not unique.
-- TODO: This may be slow -- optimise if overhead is significant.
detectWay
::
FilePath
->
Way
detectWay
extension
=
let
prefix
=
reverse
$
dropWhile
(
/=
'_'
)
$
reverse
extension
result
=
filter
((
==
prefix
)
.
wayPrefix
)
allWays
in
case
result
of
[
way
]
->
way
_
->
error
$
"Cannot detect way from extension '"
++
extension
++
"'."
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