[commit: ghc] wip/nfs-locking: Add support for --split-object command line flag. (87c6fae)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/87c6fae6c8073315ca8f5aba0e2e5501500437db/ghc

>---------------------------------------------------------------

commit 87c6fae6c8073315ca8f5aba0e2e5501500437db
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Wed Jan 20 01:00:50 2016 +0000

    Add support for --split-object command line flag.
    
    See #132.


>---------------------------------------------------------------

87c6fae6c8073315ca8f5aba0e2e5501500437db
 src/CmdLineFlag.hs   | 22 ++++++++++++++++------
 src/Settings/User.hs |  8 ++++++--
 2 files changed, 22 insertions(+), 8 deletions(-)

diff --git a/src/CmdLineFlag.hs b/src/CmdLineFlag.hs
index 444940a..05b74e5 100644
--- a/src/CmdLineFlag.hs
+++ b/src/CmdLineFlag.hs
@@ -1,5 +1,5 @@
 module CmdLineFlag (
-    putCmdLineFlags, flags, cmdProgressInfo, ProgressInfo (..)
+    putCmdLineFlags, flags, cmdProgressInfo, ProgressInfo (..), cmdSplitObjects
     ) where
 
 import Base
@@ -16,13 +16,15 @@ data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show)
 -- command line. These flags are not tracked, that is they do not force any
 -- build rules to be rurun.
 data Untracked = Untracked
-    { progressInfo :: ProgressInfo }
+    { progressInfo :: ProgressInfo
+    , splitObjects :: Bool }
     deriving (Eq, Show)
 
 -- | Default values for 'CmdLineFlag.Untracked'.
 defaultUntracked :: Untracked
 defaultUntracked = Untracked
-    { progressInfo = Normal }
+    { progressInfo = Normal
+    , splitObjects = False }
 
 readProgressInfo :: Maybe String -> Either String (Untracked -> Untracked)
 readProgressInfo ms =
@@ -35,11 +37,16 @@ readProgressInfo ms =
     go "unicorn" = Just Unicorn
     go _         = Nothing -- Left "no parse"
     mkClosure :: ProgressInfo -> Untracked -> Untracked
-    mkClosure flag opts = opts { progressInfo = flag }
+    mkClosure flag flags = flags { progressInfo = flag }
+
+readSplitObjects :: Either String (Untracked -> Untracked)
+readSplitObjects = Right $ \flags -> flags { splitObjects = True }
 
 flags :: [OptDescr (Either String (Untracked -> Untracked))]
 flags = [ Option [] ["progress-info"] (OptArg readProgressInfo "")
-          "Progress Info Style (None, Brief, Normal, or Unicorn)" ]
+          "Progress Info Style (None, Brief, Normal, or Unicorn)"
+        , Option [] ["split-objects"] (NoArg readSplitObjects)
+          "Generate split objects (requires a full clean rebuild)." ]
 
 -- TODO: Get rid of unsafePerformIO by using shakeExtra.
 {-# NOINLINE cmdLineFlags #-}
@@ -47,10 +54,13 @@ cmdLineFlags :: IORef Untracked
 cmdLineFlags = unsafePerformIO $ newIORef defaultUntracked
 
 putCmdLineFlags :: [Untracked -> Untracked] -> IO ()
-putCmdLineFlags opts = modifyIORef cmdLineFlags (\o -> foldl (flip id) o opts)
+putCmdLineFlags flags = modifyIORef cmdLineFlags (\f -> foldl (flip id) f flags)
 
 getCmdLineFlags :: Action Untracked
 getCmdLineFlags = liftIO $ readIORef cmdLineFlags
 
 cmdProgressInfo :: Action ProgressInfo
 cmdProgressInfo = progressInfo <$> getCmdLineFlags
+
+cmdSplitObjects :: Action Bool
+cmdSplitObjects = splitObjects <$> getCmdLineFlags
diff --git a/src/Settings/User.hs b/src/Settings/User.hs
index fb6ffb6..096f6ef 100644
--- a/src/Settings/User.hs
+++ b/src/Settings/User.hs
@@ -6,9 +6,12 @@ module Settings.User (
     verboseCommands, turnWarningsIntoErrors, splitObjects
     ) where
 
+import Base
+import CmdLineFlag
 import GHC
 import Expression
 import Predicates
+import Settings.Default
 
 -- | All build artefacts are stored in 'buildRootPath' directory.
 buildRootPath :: FilePath
@@ -55,9 +58,10 @@ trackBuildSystem = True
 validating :: Bool
 validating = False
 
--- To switch on split objects use 'splitObjects = defaultSplitObjects', see #153
+-- | Control when split objects are generated. Note, due to the GHC bug #11315
+-- it is necessary to do a full clean rebuild when changing this option.
 splitObjects :: Predicate
-splitObjects = return False
+splitObjects = (lift $ cmdSplitObjects) &&^ defaultSplitObjects
 
 dynamicGhcPrograms :: Bool
 dynamicGhcPrograms = False