From 76de227586804a1bf4b4a98e0307f09966348609 Mon Sep 17 00:00:00 2001
From: Andrey Mokhov <andrey.mokhov@gmail.com>
Date: Sat, 7 Jan 2017 02:55:48 +0000
Subject: [PATCH] Fix profiled GHC

See #239
---
 src/Rules.hs         | 7 ++++---
 src/Rules/Program.hs | 7 +++----
 src/Settings.hs      | 7 ++++++-
 3 files changed, 13 insertions(+), 8 deletions(-)

diff --git a/src/Rules.hs b/src/Rules.hs
index 832bf4c882..be7c89b4f1 100644
--- a/src/Rules.hs
+++ b/src/Rules.hs
@@ -49,7 +49,7 @@ topLevelTargets = do
                     docs <- interpretInContext context $ buildHaddock flavour
                     need $ libs ++ [ pkgHaddockFile context | docs && stage == Stage1 ]
                 else do -- otherwise build a program
-                    need =<< maybeToList <$> programPath context
+                    need =<< maybeToList <$> programPath (programContext stage pkg)
 
 packageRules :: Rules ()
 packageRules = do
@@ -61,21 +61,22 @@ packageRules = do
     let readPackageDb  = [(packageDb, 1)]
         writePackageDb = [(packageDb, maxConcurrentReaders)]
 
-    -- TODO: not all build rules make sense for all stage/package combinations
     let contexts        = liftM3 Context        allStages knownPackages allWays
         vanillaContexts = liftM2 vanillaContext allStages knownPackages
+        programContexts = liftM2 programContext allStages knownPackages
 
     forM_ contexts $ mconcat
         [ Rules.Compile.compilePackage readPackageDb
         , Rules.Library.buildPackageLibrary ]
 
+    forM_ programContexts $ Rules.Program.buildProgram readPackageDb
+
     forM_ vanillaContexts $ mconcat
         [ Rules.Data.buildPackageData
         , Rules.Dependencies.buildPackageDependencies readPackageDb
         , Rules.Documentation.buildPackageDocumentation
         , Rules.Library.buildPackageGhciLibrary
         , Rules.Generate.generatePackageCode
-        , Rules.Program.buildProgram readPackageDb
         , Rules.Register.registerPackage writePackageDb ]
 
 buildRules :: Rules ()
diff --git a/src/Rules/Program.hs b/src/Rules/Program.hs
index 319ca72670..92aa4c13f3 100644
--- a/src/Rules/Program.hs
+++ b/src/Rules/Program.hs
@@ -30,7 +30,7 @@ wrappers = [ (vanillaContext Stage0 ghc   , ghcWrapper   )
 buildProgram :: [(Resource, Int)] -> Context -> Rules ()
 buildProgram rs context@Context {..} = when (isProgram package) $ do
     let installStage = do
-            latest <- latestBuildStage package -- isJust below is safe
+            latest <- latestBuildStage package -- fromJust below is safe
             return $ if package == ghc then stage else fromJust latest
 
     buildPath context -/- programName context <.> exe %>
@@ -68,15 +68,14 @@ buildWrapper context@Context {..} wrapper wrapperPath binPath = do
         quote (pkgNameString package) ++ " (" ++ show stage ++ ")."
 
 -- TODO: Get rid of the Paths_hsc2hs.o hack.
--- TODO: Do we need to consider other ways when building programs?
 buildBinary :: [(Resource, Int)] -> Context -> FilePath -> Action ()
 buildBinary rs context@Context {..} bin = do
     binDeps <- if stage == Stage0 && package == ghcCabal
         then hsSources context
         else do
-            ways <- interpretInContext context getLibraryWays
             deps <- contextDependencies context
-            needContext [ dep { way = w } | dep <- deps, w <- ways ]
+            ways <- interpretInContext context (getLibraryWays <> getRtsWays)
+            needContext $ deps ++ [ rtsContext { way = w } | w <- ways ]
             let path = buildPath context
             cObjs  <- map (objectPath context) <$> pkgDataList (CSrcs path)
             hsObjs <- hsObjects context
diff --git a/src/Settings.hs b/src/Settings.hs
index 8f94e5b97a..c455e0bced 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -2,7 +2,7 @@ module Settings (
     getArgs, getPackages, getLibraryWays, getRtsWays, flavour, knownPackages,
     findKnownPackage, getPkgData, getPkgDataList, isLibrary, getPackagePath,
     getContextDirectory, getBuildPath, stagePackages, builderPath,
-    getBuilderPath, isSpecified, latestBuildStage, programPath
+    getBuilderPath, isSpecified, latestBuildStage, programPath, programContext
     ) where
 
 import Base
@@ -62,6 +62,11 @@ flavour = fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours
     flavours       = hadrianFlavours ++ userFlavours
     flavourName    = fromMaybe "default" cmdFlavour
 
+programContext :: Stage -> Package -> Context
+programContext stage pkg
+    | pkg == ghc && ghcProfiled flavour = Context stage pkg profiling
+    | otherwise = vanillaContext stage pkg
+
 -- TODO: switch to Set Package as the order of packages should not matter?
 -- Otherwise we have to keep remembering to sort packages from time to time.
 knownPackages :: [Package]