Fix profiled GHC
[hadrian.git] / src / Settings.hs
1 module Settings (
2 getArgs, getPackages, getLibraryWays, getRtsWays, flavour, knownPackages,
3 findKnownPackage, getPkgData, getPkgDataList, isLibrary, getPackagePath,
4 getContextDirectory, getBuildPath, stagePackages, builderPath,
5 getBuilderPath, isSpecified, latestBuildStage, programPath, programContext
6 ) where
7
8 import Base
9 import Context
10 import CmdLineFlag
11 import Expression
12 import Flavour
13 import GHC
14 import Oracles.PackageData
15 import Oracles.Path
16 import {-# SOURCE #-} Settings.Default
17 import Settings.Flavours.Perf
18 import Settings.Flavours.Prof
19 import Settings.Flavours.Quick
20 import Settings.Flavours.Quickest
21 import Settings.Path
22 import UserSettings
23
24 getArgs :: Expr [String]
25 getArgs = fromDiffExpr $ args flavour
26
27 getLibraryWays :: Expr [Way]
28 getLibraryWays = fromDiffExpr $ libraryWays flavour
29
30 getRtsWays :: Expr [Way]
31 getRtsWays = fromDiffExpr $ rtsWays flavour
32
33 getPackages :: Expr [Package]
34 getPackages = fromDiffExpr $ packages flavour
35
36 stagePackages :: Stage -> Action [Package]
37 stagePackages stage = interpretInContext (stageContext stage) getPackages
38
39 getPackagePath :: Expr FilePath
40 getPackagePath = pkgPath <$> getPackage
41
42 getContextDirectory :: Expr FilePath
43 getContextDirectory = stageDirectory <$> getStage
44
45 getBuildPath :: Expr FilePath
46 getBuildPath = buildPath <$> getContext
47
48 getPkgData :: (FilePath -> PackageData) -> Expr String
49 getPkgData key = lift . pkgData . key =<< getBuildPath
50
51 getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
52 getPkgDataList key = lift . pkgDataList . key =<< getBuildPath
53
54 hadrianFlavours :: [Flavour]
55 hadrianFlavours = [ defaultFlavour, perfFlavour, profFlavour, quickFlavour
56 , quickestFlavour ]
57
58 flavour :: Flavour
59 flavour = fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours
60 where
61 unknownFlavour = error $ "Unknown build flavour: " ++ flavourName
62 flavours = hadrianFlavours ++ userFlavours
63 flavourName = fromMaybe "default" cmdFlavour
64
65 programContext :: Stage -> Package -> Context
66 programContext stage pkg
67 | pkg == ghc && ghcProfiled flavour = Context stage pkg profiling
68 | otherwise = vanillaContext stage pkg
69
70 -- TODO: switch to Set Package as the order of packages should not matter?
71 -- Otherwise we have to keep remembering to sort packages from time to time.
72 knownPackages :: [Package]
73 knownPackages = sort $ defaultKnownPackages ++ userKnownPackages
74
75 -- TODO: Speed up?
76 -- Note: this is slow but we keep it simple as there are just ~50 packages
77 findKnownPackage :: PackageName -> Maybe Package
78 findKnownPackage name = find (\pkg -> pkgName pkg == name) knownPackages
79
80 -- | Determine the location of a 'Builder'.
81 builderPath :: Builder -> Action FilePath
82 builderPath builder = case builderProvenance builder of
83 Nothing -> systemBuilderPath builder
84 Just context -> do
85 maybePath <- programPath context
86 let msg = error $ show builder ++ " is never built by Hadrian."
87 return $ fromMaybe msg maybePath
88
89 getBuilderPath :: Builder -> ReaderT a Action FilePath
90 getBuilderPath = lift . builderPath
91
92 -- | Was the path to a given 'Builder' specified in configuration files?
93 isSpecified :: Builder -> Action Bool
94 isSpecified = fmap (not . null) . builderPath
95
96 -- | Determine the latest 'Stage' in which a given 'Package' is built. Returns
97 -- Nothing if the package is never built.
98 latestBuildStage :: Package -> Action (Maybe Stage)
99 latestBuildStage pkg = do
100 stages <- filterM (fmap (pkg `elem`) . stagePackages) [Stage0 ..]
101 return $ if null stages then Nothing else Just $ maximum stages
102
103 -- | The 'FilePath' to a program executable in a given 'Context'.
104 programPath :: Context -> Action (Maybe FilePath)
105 programPath context@Context {..} = do
106 maybeLatest <- latestBuildStage package
107 return $ do
108 install <- (\l -> l == stage || package == ghc) <$> maybeLatest
109 let path = if install then installPath package else buildPath context
110 return $ path -/- programName context <.> exe