Commit 37262111 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Rename Ways.hs => Way.hs and refactor it.

parent 9bde7d86
...@@ -27,10 +27,6 @@ data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum, Generic) ...@@ -27,10 +27,6 @@ data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum, Generic)
instance Show Stage where instance Show Stage where
show = show . fromEnum 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 -- The returned string or list of strings is a part of an argument list
-- to be passed to a Builder -- to be passed to a Builder
type Arg = Action String type Arg = Action String
...@@ -73,3 +69,7 @@ concatArgs as bs = do ...@@ -73,3 +69,7 @@ concatArgs as bs = do
as' <- showArgs as as' <- showArgs as
bs' <- showArgs bs bs' <- showArgs bs
return $ map concat $ sequence [as', bs'] return $ map concat $ sequence [as', bs']
-- Instances for storing in the Shake database
instance Binary Stage
instance Hashable Stage
...@@ -87,6 +87,6 @@ needBuilder builder = do ...@@ -87,6 +87,6 @@ needBuilder builder = do
path <- builderPath builder path <- builderPath builder
need [path] need [path]
-- Instances for storing Target in the Shake database -- Instances for storing in the Shake database
instance Binary Builder instance Binary Builder
instance Hashable Builder instance Hashable Builder
...@@ -11,8 +11,8 @@ module Expression ( ...@@ -11,8 +11,8 @@ module Expression (
configKeyValue, configKeyValues configKeyValue, configKeyValues
) where ) where
import Way
import Base import Base
import Ways
import Builder import Builder
import Package import Package
import Target import Target
......
...@@ -25,11 +25,6 @@ instance Eq Package where ...@@ -25,11 +25,6 @@ instance Eq Package where
instance Ord Package where instance Ord Package where
compare = compare `on` pkgName compare = compare `on` pkgName
instance Binary Package
instance Hashable Package where
hashWithSalt salt = hashWithSalt salt . show
-- TODO: check if unifyPath is actually needed -- TODO: check if unifyPath is actually needed
library :: String -> Package library :: String -> Package
library name = library name =
...@@ -40,3 +35,8 @@ topLevel name = Package name name (name <.> "cabal") ...@@ -40,3 +35,8 @@ topLevel name = Package name name (name <.> "cabal")
setCabal :: Package -> FilePath -> Package setCabal :: Package -> FilePath -> Package
setCabal pkg cabalName = pkg { pkgCabal = cabalName } 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
...@@ -4,6 +4,7 @@ module Rules.Data ( ...@@ -4,6 +4,7 @@ module Rules.Data (
cabalArgs, ghcPkgArgs, buildPackageData cabalArgs, ghcPkgArgs, buildPackageData
) where ) where
import Way
import Base import Base
import Package import Package
import Builder import Builder
...@@ -14,7 +15,6 @@ import Settings.GhcCabal ...@@ -14,7 +15,6 @@ import Settings.GhcCabal
import Settings.TargetDirectory import Settings.TargetDirectory
import Rules.Actions import Rules.Actions
import Util import Util
import Ways
-- Build package-data.mk by using GhcCabal to process pkgCabal file -- Build package-data.mk by using GhcCabal to process pkgCabal file
buildPackageData :: StagePackageTarget -> Rules () buildPackageData :: StagePackageTarget -> Rules ()
......
...@@ -2,10 +2,10 @@ module Settings.GhcCabal ( ...@@ -2,10 +2,10 @@ module Settings.GhcCabal (
cabalArgs, bootPackageDbArgs, customPackageArgs cabalArgs, bootPackageDbArgs, customPackageArgs
) where ) where
import Way
import Base import Base
import Builder import Builder
import Package import Package
import Ways
import Util import Util
import Oracles.Base import Oracles.Base
import Switches import Switches
......
...@@ -102,3 +102,18 @@ appendCcArgs xs = do ...@@ -102,3 +102,18 @@ appendCcArgs xs = do
-- -- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ... -- -- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
-- argPrefixPath :: String -> Args -> Args -- argPrefixPath :: String -> Args -> Args
-- argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return) -- 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"] ]
...@@ -2,8 +2,8 @@ module Settings.Ways ( ...@@ -2,8 +2,8 @@ module Settings.Ways (
ways ways
) where ) where
import Way
import Base import Base
import Ways
import Switches import Switches
import Expression import Expression
import Settings.User import Settings.User
......
...@@ -4,8 +4,8 @@ module Target ( ...@@ -4,8 +4,8 @@ module Target (
stageTarget, stagePackageTarget, fullTarget stageTarget, stagePackageTarget, fullTarget
) where ) where
import Way
import Base import Base
import Ways
import Package import Package
import Builder import Builder
import GHC.Generics import GHC.Generics
...@@ -70,7 +70,7 @@ instance Show FullTarget where ...@@ -70,7 +70,7 @@ instance Show FullTarget where
++ " (" ++ show (getBuilder target) ++ " (" ++ show (getBuilder target)
++ ", " ++ show (getWay target) ++ ")" ++ ", " ++ show (getWay target) ++ ")"
-- Instances for storing FullTarget in the Shake database -- Instances for storing in the Shake database
instance Binary FullTarget instance Binary FullTarget
instance NFData FullTarget instance NFData FullTarget
instance Hashable FullTarget instance Hashable FullTarget
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
{-# 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 ++ "'."
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment