summaryrefslogtreecommitdiff
path: root/hadrian/src/Flavour.hs
blob: d8f34347f40238fcbdbda6a8296e373f666aa9df (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
module Flavour
  ( Flavour (..), werror
  , DocTargets, DocTarget(..)
  , parseFlavour
    -- * Flavour transformers
  , flavourTransformers
  , addArgs
  , splitSections, splitSectionsIf
  , enableThreadSanitizer
  , enableDebugInfo, enableTickyGhc
  , viaLlvmBackend
  , enableProfiledGhc
  , disableDynamicGhcPrograms
  , disableProfiledLibs

  , completeSetting
  , applySettings
  ) where

import Expression
import Data.Either
import Data.Map (Map)
import qualified Data.Map as M
import Packages
import Flavour.Type
import Settings.Parser

import Text.Parsec.Prim as P
import Text.Parsec.Combinator as P
import Text.Parsec.Char as P
import Control.Monad.Except
import UserSettings


flavourTransformers :: Map String (Flavour -> Flavour)
flavourTransformers = M.fromList
    [ "werror" =: werror
    , "debug_info" =: enableDebugInfo
    , "ticky_ghc" =: enableTickyGhc
    , "split_sections" =: splitSections
    , "thread_sanitizer" =: enableThreadSanitizer
    , "llvm" =: viaLlvmBackend
    , "profiled_ghc" =: enableProfiledGhc
    , "no_dynamic_ghc" =: disableDynamicGhcPrograms
    , "no_profiled_libs" =: disableProfiledLibs
    , "omit_pragmas" =: omitPragmas
    ]
  where (=:) = (,)

type Parser = Parsec String ()

parseFlavour :: [Flavour]  -- ^ base flavours
             -> Map String (Flavour -> Flavour) -- ^ modifiers
             -> String
             -> Either String Flavour
parseFlavour baseFlavours transformers str =
    case P.runParser parser () "" str of
      Left perr -> Left $ unlines $
                    [ "error parsing flavour specifier: " ++ show perr
                    , ""
                    , "known flavours:"
                    ] ++
                    [ "  " ++ name f | f <- baseFlavours ] ++
                    [ ""
                    , "known flavour transformers:"
                    ] ++
                    [ "  " ++ nm | nm <- M.keys transformers ]
      Right f -> Right f
  where
    parser :: Parser Flavour
    parser = do
      base <- baseFlavour
      transs <- P.many flavourTrans
      P.eof
      return $ foldr ($) base transs

    baseFlavour :: Parser Flavour
    baseFlavour =
        P.choice [ f <$ P.try (P.string (name f))
                 | f <- reverse (sortOn name baseFlavours)
                 ]      -- needed to parse e.g. "quick-debug" before "quick"

    flavourTrans :: Parser (Flavour -> Flavour)
    flavourTrans = do
        void $ P.char '+'
        P.choice [ trans <$ P.try (P.string nm)
                 | (nm, trans) <- M.toList transformers
                 ]

-- | Add arguments to the 'args' of a 'Flavour'.
addArgs :: Args -> Flavour -> Flavour
addArgs args' fl = fl { args = args fl <> args' }

-- | Turn on -Werror for packages built with the stage1 compiler.
-- It mimics the CI settings so is useful to turn on when developing.
werror :: Flavour -> Flavour
werror = addArgs (builder Ghc ? notStage0 ? arg "-Werror")

-- | Build C and Haskell objects with debugging information.
enableDebugInfo :: Flavour -> Flavour
enableDebugInfo = addArgs $ notStage0 ? mconcat
    [ builder (Ghc CompileHs) ? arg "-g3"
    , builder (Cc CompileC) ? arg "-g3"
    , builder (Cabal Setup) ? arg "--disable-library-stripping"
    , builder (Cabal Setup) ? arg "--disable-executable-stripping"
    ]

-- | Enable the ticky-ticky profiler in stage2 GHC
enableTickyGhc :: Flavour -> Flavour
enableTickyGhc =
    addArgs $ stage1 ? mconcat
      [ builder (Ghc CompileHs) ? ticky
      , builder (Ghc LinkHs) ? ticky
      ]
  where
    ticky = mconcat
      [ arg "-ticky"
      , arg "-ticky-allocd"
      , arg "-ticky-dyn-thunk"
      -- You generally need STG dumps to interpret ticky profiles
      , arg "-ddump-to-file"
      , arg "-ddump-stg-final"
      ]

-- | Transform the input 'Flavour' so as to build with
--   @-split-sections@ whenever appropriate. You can
--   select which package gets built with split sections
--   by passing a suitable predicate. If the predicate holds
--   for a given package, then @split-sections@ is used when
--   building it. If the given flavour doesn't build
--   anything in a @dyn@-enabled way, then 'splitSections' is a no-op.
splitSectionsIf :: (Package -> Bool) -> Flavour -> Flavour
splitSectionsIf pkgPredicate = addArgs $ do
    way <- getWay
    pkg <- getPackage
    (Dynamic `wayUnit` way) ? pkgPredicate pkg ?
        builder (Ghc CompileHs) ? arg "-split-sections"

-- | Like 'splitSectionsIf', but with a fixed predicate: use
--   split sections for all packages but the GHC library.
splitSections :: Flavour -> Flavour
splitSections = splitSectionsIf (/=ghc)
-- Disable section splitting for the GHC library. It takes too long and
-- there is little benefit.

enableThreadSanitizer :: Flavour -> Flavour
enableThreadSanitizer = addArgs $ mconcat
    [ builder (Ghc CompileHs) ? arg "-optc-fsanitize=thread"
    , builder (Ghc CompileCWithGhc) ? (arg "-optc-fsanitize=thread" <> arg "-DTSAN_ENABLED")
    , builder (Ghc LinkHs) ? arg "-optl-fsanitize=thread"
    , builder (Cc  CompileC) ? (arg "-fsanitize=thread" <> arg "-DTSAN_ENABLED")
    , builder (Cabal Flags) ? arg "thread-sanitizer"
    , builder  RunTest ? arg "--config=have_thread_sanitizer=True"
    ]

-- | Use the LLVM backend in stages 1 and later.
viaLlvmBackend :: Flavour -> Flavour
viaLlvmBackend = addArgs $ notStage0 ? builder Ghc ? arg "-fllvm"

-- | Build the GHC executable with profiling enabled. It is also recommended
-- that you use this with @'dynamicGhcPrograms' = False@ since GHC does not
-- support loading of profiled libraries with the dynamically-linker.
enableProfiledGhc :: Flavour -> Flavour
enableProfiledGhc flavour =
    flavour { rtsWays = addWays [profiling, threadedProfiling, debugProfiling, threadedDebugProfiling] (rtsWays flavour)
            , libraryWays = addWays [profiling] (libraryWays flavour)
            , ghcProfiled = True
            }
  where
    addWays :: [Way] -> Ways -> Ways
    addWays ways =
      fmap (++ ways)

-- | Disable 'dynamicGhcPrograms'.
disableDynamicGhcPrograms :: Flavour -> Flavour
disableDynamicGhcPrograms flavour = flavour { dynamicGhcPrograms = pure False }

-- | Don't build libraries in profiled 'Way's.
disableProfiledLibs :: Flavour -> Flavour
disableProfiledLibs flavour =
    flavour { libraryWays = filter (not . wayUnit Profiling) <$> libraryWays flavour }

-- | Build stage2 compiler with -fomit-interface-pragmas to reduce
-- recompilation.
omitPragmas :: Flavour -> Flavour
omitPragmas =
  let Right kv = parseKV "stage1.ghc.ghc.hs.opts += -fomit-interface-pragmas"
      Right transformer = applySetting kv
  in transformer

-- * CLI and <root>/hadrian.settings options

{-
Note [Hadrian settings]
~~~~~~~~~~~~~~~~~~~~~~~

Hadrian lets one customize GHC builds through the UserSettings module,
where Hadrian users can override existing 'Flavour's or create entirely
new ones, overriding/extending the options passed to some builder
building the RTS in more ways and much more.

It now also offers a more "old-school" interface, in the form of
@foo.bar.baz = v@ or @foo.bar.baz += v@ expressions, that one can
pass on the command line that invokes hadrian:

> $ hadrian/build --flavour=quickest -j "stage1.ghc-bin.ghc.link.opts += -v3"

or in a file at <build root>/hadrian.settings, where <build root>
is the build root to be used for the build, which is _build by default.
For example, you could create a file at _build/hadrian.settings with the
following contents:

> stage1.ghc-bin.ghc.link.opts += -v3
> stage1.base.ghc.hs.opts += -ddump-timings

and issue:

> $ hadrian/build

Hadrian would pick up the settings given in _build/hadrian.settings (as well as
any settings that you may additionally be passing on the command line) and
update the relevant flavour accordingly, to issue the additional arguments
specified by the user.

The supported settings are described by 'builderSetting' below, using
operations from Applicative + two new primitives, 'matchString' and
'matchOneOf', that come as members of the 'Match' class. This gives us
a simple but powerful vocabulary to describe settings and parse them
into values that we can use to compute interesting things, like a 'Predicate'
that we can use to emit additional arguments, or a list of possible completions.

> fmap, (<$>) :: Functor f => (a -> b) -> f a -> f b
> pure :: Applicative f => a -> f a
> (<*>) :: Applicative f => f (a -> b) -> f a -> f b
> (*>) :: Applicative f => f a -> f b -> f b
> (<*) :: Applicative f => f a -> f b -> f a
> (<$) :: Functor f => a -> f b -> f a
>
> str :: Match f => String -> f ()
> val :: Match f => String -> a -> f a
> oneOf :: Match f => [f a] -> f a
> choose :: Match f => [(String, a)] -> f a
> wild :: Match f => [(String, a)] -> f (Wildcard a)

For instance, to describe possible settings:
  foo.bar.{x, y}
  foo.baz.{a, b}.c

we could write:

> str "foo" *> oneOf [ str "bar" *> choose [ ("x", "x"), ("y", "y") ]
>                    , str "baz" *> choose [ ("a", "ac"), ("b", "bc") <* str "c" ]
>                    ]

'builderSetting' uses these combinators to describe the setting keys that
Hadrian supports. A user-oriented description of this mechanism is available
in hadrian/doc/user-settings.md.

-}

-- | Try to interpret all the 'KeyVal' as flavour updates, keeping
--   a list of errors for the ones which don't match known
--   settings.
applySettings :: [KeyVal] -> ([SettingError], Flavour -> Flavour)
applySettings kvs = case partitionEithers (map applySetting kvs) of
  (errs, fs) -> (errs, foldr (flip (.)) id fs)
  -- we need to compose the reverse way to have the following settings
  --     x  = -b
  --     x += -c
  -- produce the final x = "-b -c" value. With just (.) we would apply
  -- the x = -b assignment last, which would silently drop the -c adddition.
  --
  --     foldr (.) id [f, g, h] = f . g . h
  --        -- first function (f) is applied last, we're applying them in
  --        -- the wrong order!
  --
  --     foldr (flip (.)) id [f, g, h] = h . g . f
  --        -- last function (f) is applied last, as desired


-- | Try to interpret the given 'KeyVal' as a flavour update
--   function, returning an error if it doesn't match a known
--   setting.
applySetting :: KeyVal -> Either SettingError (Flavour -> Flavour)
applySetting (KeyVal ks op v) = case runSettingsM ks builderPredicate of
  Left err -> throwError $
      "error while setting `" ++ intercalate "`." ks ++ ": " ++ err
  Right pred -> Right $ \flav -> flav
    { args = update (args flav) pred }

  where override arguments predicate = do
          holds <- predicate
          if holds then pure (words v) else arguments

        augment arguments predicate =
          mconcat [arguments, predicate ? pure (words v)]

        update
          | op == Equal = override
          | otherwise   = augment

-- | Try to auto-complete the given @Key@ using
--   all known settings, as described by 'builderSetting'.
--
-- > completeSetting ["stage1","base", "ghc"]
-- >   -- returns [ ["stage1","base","ghc","c","opts"]
-- >   --         , ["stage1","base","ghc","hs","opts"]
-- >   --         , ["stage1","base","ghc","link","opts"]
-- >   --         , ["stage1","base","ghc","deps","opts"]
-- >   --         , ["stage1","base","ghc","toolargs","opts"]
-- >   --         ]
completeSetting :: Key -> [Key]
completeSetting ks = map snd (complete ks builderSetting)

-- | Interpret a 'builderSetting' as a 'Predicate' that
--   potentially constrains on the stage, package or
--   (ghc or cc) builder mode.
--
--   For example, @stage1.base.ghc.link.opts@ gets mapped to
--   a predicate that applies @'stage' 'Stage1'@,
--   @'package' 'base'@ and @'builder' ('Ghc' 'LinkHs')@.
builderPredicate :: SettingsM Predicate
builderPredicate = builderSetting <&> (\(wstg, wpkg, builderMode) ->
  wildcard (pure True) stage wstg <&&>
  wildcard (pure True) package wpkg <&&>
    (case builderMode of
       BM_Ghc ghcMode -> wildcard (builder Ghc) (builder . Ghc) ghcMode
       BM_Cc  ccMode  -> wildcard (builder Cc) (builder . Cc) ccMode
       BM_CabalConfigure -> builder (Cabal Setup)
       BM_RunTest     -> builder RunTest
    )
  )

  where (<&&>) = liftA2 (&&)

-- | Which builder a setting should apply to
data BuilderMode = BM_Ghc (Wildcard GhcMode)
                 | BM_Cc  (Wildcard CcMode)
                 | BM_CabalConfigure
                 | BM_RunTest

-- | Interpretation-agnostic description of the builder settings
--   supported by Hadrian.
--
--   Supported settings (to be kept in sync with the code):
--
--   > (<stage> or *).(<package name> or *).ghc.(<ghc mode> or *).opts
--   > (<stage> or *).(<package name> or *).cc.(<cc mode> or *).opts
--   > (<stage> or *).(<package name> or *).cabal.configure.opts
--   > runtest.opts
--
--   where:
--     - @<stage>@ is one of @stage0@, @stage1@, @stage2@ or @stage3@;
--     - @<package name>@ is the (Cabal) name of a package (@base@,
--       @template-haskell@, ...);
--     - @<ghc mode>@ is one of @c@ (building C files), @hs@ (building Haskell
--       modules), @link@ (linking object files), @deps@ (finding Haskell
--       dependencies with @ghc -M@) or @toolargs@ (getting necessary flags to
--       make hadrian/ghci work;
--     - @<cc mode>@ is one of @c@ (building C files) or @deps@ (finding C
--       dependencies);
--     - locations that support a wildcard (@*@) entry are here to avoid
--       repetition, a wildcard entry being equivalent to writing all the
--       settings that the wildcard matches over; in our case, we can
--       apply GHC or C compiler options uniformly over all stages, packages
--       and compiler modes, if we so desire, by using a wildcard in the
--       appropriate spot.
builderSetting :: Match f
               => f (Wildcard Stage, Wildcard Package, BuilderMode)
builderSetting =
    matchOneOf
    [ (,,)
       <$> wild stages
       <*> wild pkgs
       <*> matchOneOf
             [ str "ghc" *> fmap BM_Ghc (wild ghcBuilder) <* str "opts"
             , str "cc" *> fmap BM_Cc (wild ccBuilder) <* str "opts"
             , BM_CabalConfigure <$ str "cabal" <* str "configure" <* str "opts"
             ]
    , (Wildcard, Wildcard, BM_RunTest)
      <$ str "runtest" <* str "opts"
    ]
  where ghcBuilder =
          [ ("c", CompileCWithGhc)
          , ("cpp", CompileCppWithGhc)
          , ("deps", FindHsDependencies)
          , ("hs", CompileHs)
          , ("link", LinkHs)
          , ("toolargs", ToolArgs)
          ]

        ccBuilder =
          [ ("c", CompileC)
          , ("deps", FindCDependencies)
          ]

        stages = map (\stg -> (stageString stg, stg)) [minBound..maxBound]

        pkgs = map (\pkg -> (pkgName pkg, pkg)) (ghcPackages ++ userPackages)