Improve, fix.

Cabal/src/Distribution/Simple/GHC/Build.hs

@@ -126,7 +126,13 @@ build numJobs pkg_descr = do
   -- We need a separate build and link phase, and C sources must be compiled
   -- after Haskell modules, because C sources may depend on stub headers
   -- generated from compiling Haskell modules (#842).
-  (vanillaOpts, wantedWaysMap) <-
-    buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir wantedWays
+  buildOpts <- buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir wantedWays
   extraSources <- buildAllExtraSources ghcProg
-  linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) vanillaOpts wantedWaysMap
+  liftIO $ do
+    putStrLn "ROMES:########################"
+    putStrLn "Wanted ways"
+    print wantedWays
+    putStrLn "Extra sources"
+    print extraSources
+    putStrLn "END:ROMES:########################"
+  linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) (wantedWays, buildOpts)

Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs

@@ -231,11 +231,10 @@ buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcP
             componentBuildDir lbi clbi
               </> componentNameRaw cname <> "-tmp"
      in
-      do
-        -- build any sources
-        if (null sources || componentIsIndefinite clbi)
-          then do
-            info verbosity ("Building " ++ description ++ "...")
-            traverse_ buildAction sources
-            return sources
-          else return []
+      -- build any sources
+      if (null sources || componentIsIndefinite clbi)
+        then return []
+        else do
+          info verbosity ("Building " ++ description ++ "...")
+          traverse_ buildAction sources
+          return sources

Cabal/src/Distribution/Simple/GHC/Build/Link.hs

@@ -10,7 +10,7 @@ import Control.Monad (forM_)
 import Control.Monad.IO.Class
 import qualified Data.ByteString.Lazy.Char8 as BS
 import Data.Function ((&))
-import qualified Data.Map as Map
+import qualified Data.Set as Set
 import Distribution.Compat.Binary (encode)
 import Distribution.Compat.ResponseFile
 import Distribution.InstalledPackageInfo (InstalledPackageInfo)
@@ -61,13 +61,12 @@ linkOrLoadComponent
   -> (FilePath, FilePath)
   -- ^ The build target dir, and the target dir.
   -- See Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build
-  -> GhcOptions
-  -- ^ The vanilla base options used across build invocations
-  -- of GHC, which may be used for loading the component in the repl.
-  -> Map.Map BuildWay GhcOptions
-  -- ^ The set of build ways wanted based on the user opts
+  -> (Set.Set BuildWay, BuildWay -> GhcOptions)
+  -- ^ The set of build ways wanted based on the user opts, and a function to
+  -- convert a build way into the set of ghc options that were used to build
+  -- that way.
   -> BuildM ()
-linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) vanillaOpts wantedWaysMap = do
+linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) (wantedWays, buildOpts) = do
   verbosity <- buildVerbosity
   target <- buildTarget
   component <- buildComponent
@@ -112,10 +111,13 @@ linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) v
         , ghcOptLinkFrameworks = toNubListR $ PD.frameworks bi
         , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs bi
         , ghcOptInputFiles = toNubListR [buildTargetDir </> x | x <- extraSourcesObjs]
+        , ghcOptNoLink = Flag False
         }
   case what of
     BuildRepl replFlags -> liftIO $ do
       let
+        -- For repl we use the vanilla base ghc options
+        vanillaOpts = buildOpts VanillaWay
         replOpts =
           vanillaOpts
             { ghcOptExtra =
@@ -135,11 +137,13 @@ linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) v
               { ghcOptMode = toFlag GhcModeInteractive
               , ghcOptOptimisation = toFlag GhcNoOptimisation
               }
+      print ("BUILDING REPLT BASE OPTS", vanillaOpts)
 
       -- TODO: problem here is we need the .c files built first, so we can load them
       -- with ghci, but .c files can depend on .h files generated by ghc by ffi
       -- exports.
-      when (case component of CLib lib -> null (allLibModules lib clbi); _ -> False) $ warn verbosity "No exposed modules"
+      when (case component of CLib lib -> null (allLibModules lib clbi); _ -> False) $
+        warn verbosity "No exposed modules"
       runReplOrWriteFlags ghcProg lbi replFlags replOpts (pkgName (PD.package pkg_descr)) target
     _otherwise ->
       let
@@ -148,15 +152,16 @@ linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) v
         comp = compiler lbi
        in
         when (not $ componentIsIndefinite clbi) $ do
-          rpaths <- if DynWay `elem` Map.keys wantedWaysMap then getRPaths else return (toNubListR [])
+          rpaths <- if DynWay `Set.member` wantedWays then getRPaths else return (toNubListR [])
           liftIO $ do
             info verbosity "Linking..."
+            let linkExeLike name = linkExecutable (linkerOpts, rpaths) (wantedWays, buildOpts) targetDir name runGhcProg lbi
             case component of
-              CLib lib -> linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWaysMap
-              CFLib flib -> linkFLib flib bi lbi (linkerOpts, rpaths) wantedWaysMap targetDir runGhcProg
-              CExe exe -> linkExecutable (linkerOpts, rpaths) wantedWaysMap targetDir (exeName exe) runGhcProg lbi
-              CTest test -> linkExecutable (linkerOpts, rpaths) wantedWaysMap targetDir (testName test) runGhcProg lbi
-              CBench bench -> linkExecutable (linkerOpts, rpaths) wantedWaysMap targetDir (benchmarkName bench) runGhcProg lbi
+              CLib lib -> linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays
+              CFLib flib -> linkFLib flib bi lbi (linkerOpts, rpaths) (wantedWays, buildOpts) targetDir runGhcProg
+              CExe exe -> linkExeLike (exeName exe)
+              CTest test -> linkExeLike (testName test)
+              CBench bench -> linkExeLike (benchmarkName bench)
 
 -- ROMES:TODO: This module can still be very much refactored. I'm pretty sure we
 -- can merge all implementations of link for each component into one simpler
@@ -181,10 +186,10 @@ linkLibrary
   -- ^ Extra build sources (that were compiled to objects)
   -> NubListR FilePath
   -- ^ A list with the runtime-paths (rpaths), or empty if not linking dynamically
-  -> Map.Map BuildWay GhcOptions
+  -> Set.Set BuildWay
   -- ^ Wanted build ways and corresponding build options
   -> IO ()
-linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWaysMap = do
+linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays = do
   let
     compiler_id = compilerId comp
     comp = compiler lbi
@@ -240,18 +245,47 @@ linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg li
           ]
 
     -- ROMES:TODO: I'm fairly certain that, just like the executable, we can keep just the
-    -- module input list, and point to the right output dir (as is already
+    -- module input list, and point to the right sources dir (as is already
     -- done), and GHC will pick up the right suffix (p_ for profile, dyn_ when
-    -- -shared...). That would mean the size of linking the lib would be just
-    -- like the executable, and we could merge the two.
+    -- -shared...). That would mean linking the lib would be just like the executable, and we could more easily merge the two.
+    --
+    -- Right now, instead, we pass the path to each object file.
+    ghcBaseLinkArgs =
+      mempty
+        { ghcOptExtra = hcStaticOptions GHC libBi
+        , ghcOptHideAllPackages = toFlag True
+        , ghcOptNoAutoLinkPackages = toFlag True
+        , ghcOptPackageDBs = withPackageDB lbi
+        , ghcOptThisUnitId = case clbi of
+            LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->
+              toFlag pk
+            _ -> mempty
+        , ghcOptThisComponentId = case clbi of
+            LibComponentLocalBuildInfo
+              { componentInstantiatedWith = insts
+              } ->
+                if null insts
+                  then mempty
+                  else toFlag (componentComponentId clbi)
+            _ -> mempty
+        , ghcOptInstantiatedWith = case clbi of
+            LibComponentLocalBuildInfo
+              { componentInstantiatedWith = insts
+              } ->
+                insts
+            _ -> []
+        , ghcOptPackages =
+            toNubListR $
+              Internal.mkGhcOptPackages mempty clbi
+        }
 
     -- After the relocation lib is created we invoke ghc -shared
     -- with the dependencies spelled out as -package arguments
     -- and ghc invokes the linker with the proper library paths
-    ghcSharedLinkArgs dynOpts dynObjectFiles =
-      dynOpts
-        { ghcOptMode = toFlag GhcModeLink
-        , ghcOptShared = toFlag True
+    ghcSharedLinkArgs dynObjectFiles =
+      ghcBaseLinkArgs
+        { ghcOptShared = toFlag True
+        , ghcOptDynLinkMode = toFlag GhcDynamicOnly
         , ghcOptInputFiles = toNubListR dynObjectFiles
         , ghcOptOutputFile = toFlag sharedLibFilePath
         , -- For dynamic libs, Mac OS/X needs to know the install location
@@ -262,33 +296,59 @@ linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg li
               && ghcVersion < mkVersion [7, 8]
               then toFlag sharedLibInstallPath
               else mempty
-        , ghcOptNoAutoLinkPackages = toFlag True
         , ghcOptLinkLibs = extraLibs libBi
         , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs
         , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi
         , ghcOptLinkFrameworkDirs =
             toNubListR $ PD.extraFrameworkDirs libBi
         , ghcOptRPaths = rpaths
         }
-    ghcStaticLinkArgs staticOpts staticObjectFiles =
-      staticOpts
-        { ghcOptMode = toFlag GhcModeLink
-        , ghcOptStaticLib = toFlag True
+      -- dynOpts
+      --   { ghcOptMode = toFlag GhcModeLink
+      --   , ghcOptShared = toFlag True
+      --   , ghcOptInputFiles = toNubListR dynObjectFiles
+      --   , ghcOptOutputFile = toFlag sharedLibFilePath
+      --   , -- For dynamic libs, Mac OS/X needs to know the install location
+      --     -- at build time. This only applies to GHC < 7.8 - see the
+      --     -- discussion in #1660.
+      --     ghcOptDylibName =
+      --       if hostOS == OSX
+      --         && ghcVersion < mkVersion [7, 8]
+      --         then toFlag sharedLibInstallPath
+      --         else mempty
+      --   , ghcOptNoAutoLinkPackages = toFlag True
+      --   , ghcOptLinkLibs = extraLibs libBi
+      --   , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs
+      --   , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi
+      --   , ghcOptLinkFrameworkDirs =
+      --       toNubListR $ PD.extraFrameworkDirs libBi
+      --   , ghcOptRPaths = rpaths
+      --   }
+    ghcStaticLinkArgs staticObjectFiles =
+      ghcBaseLinkArgs
+        { ghcOptStaticLib = toFlag True
         , ghcOptInputFiles = toNubListR staticObjectFiles
         , ghcOptOutputFile = toFlag staticLibFilePath
-        , ghcOptNoAutoLinkPackages = toFlag True
         , ghcOptLinkLibs = extraLibs libBi
-        , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs -- ROMES:TODO: why not extra dirs static???
+        , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs -- ROMES:TODO: why not extra dirs *static*???
         }
-  -- ROMES:TODO: Try to figure out if we could do the same "commonOpt `mappend` linkerOpts" as we do for repl here
+      -- staticOpts
+      --   { ghcOptMode = toFlag GhcModeLink
+      --   , ghcOptStaticLib = toFlag True
+      --   , ghcOptInputFiles = toNubListR staticObjectFiles
+      --   , ghcOptOutputFile = toFlag staticLibFilePath
+      --   , ghcOptNoAutoLinkPackages = toFlag True
+      --   , ghcOptLinkLibs = extraLibs libBi
+      --   , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs -- ROMES:TODO: why not extra dirs *static*???
+      --   }
 
   staticObjectFiles <- getObjFiles StaticWay
   profObjectFiles <- getObjFiles ProfWay
   dynamicObjectFiles <- getObjFiles DynWay
 
   let
     linkWay = \case
-      (VanillaWay, _vanillaOpts) -> do
+      VanillaWay -> do
         Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles
         when (withGHCiLib lbi) $ do
           (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
@@ -298,7 +358,7 @@ linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg li
             ldProg
             ghciLibFilePath
             staticObjectFiles
-      (ProfWay, _profOpts) -> do
+      ProfWay -> do
         Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles
         when (withGHCiLib lbi) $ do
           (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
@@ -308,17 +368,16 @@ linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg li
             ldProg
             ghciProfLibFilePath
             profObjectFiles
-      (DynWay, dynOpts) -> do
-        runGhcProg $ ghcSharedLinkArgs dynOpts dynamicObjectFiles
-      (StaticWay, staticOpts) ->
-        runGhcProg $ ghcStaticLinkArgs staticOpts staticObjectFiles
+      DynWay -> do
+        runGhcProg $ ghcSharedLinkArgs {- (buildOpts DynWay) -} dynamicObjectFiles
+      StaticWay ->
+        runGhcProg $ ghcStaticLinkArgs {- (buildOpts StaticWay) -} staticObjectFiles
 
   -- ROMES: Why exactly branch on staticObjectFiles, rather than any other build
   -- kind that we might have wanted instead?
   unless (null staticObjectFiles) $ do
     info verbosity (show (ghcOptPackages (Internal.componentGhcOptions verbosity lbi libBi clbi buildTargetDir)))
-
-    traverse_ linkWay (Map.toList wantedWaysMap)
+    traverse_ linkWay wantedWays
 
 -- ROMES:TODO: Have to be careful about target dir vs build dir here! They are
 -- not the same on exes, and we don't want to conflate them for now, even
@@ -330,7 +389,7 @@ linkExecutable
   :: (GhcOptions, NubListR FilePath)
   -- ^ The linker-specific GHC options, and the RPaths to include
   -- in dynamically linked binaries
-  -> Map.Map BuildWay GhcOptions
+  -> (Set.Set BuildWay, BuildWay -> GhcOptions)
   -- ^ The wanted build ways and corresponding GhcOptions that were
   -- used to compile the modules in that way.
   -> FilePath
@@ -342,15 +401,14 @@ linkExecutable
   -- ^ Run the configured GHC program
   -> LocalBuildInfo
   -> IO ()
-linkExecutable (linkerOpts, rpaths) wantedWaysMap targetDir targetName runGhcProg lbi =
+linkExecutable (linkerOpts, rpaths) (wantedWays, buildOpts) targetDir targetName runGhcProg lbi = do
   -- When building an executable, we should only "want" one build way.
-  assert (Map.size wantedWaysMap == 1) $
-    forM_ wantedWaysMap $ \opts -> do
-      let linkOpts =
-            opts
-              `mappend` linkerOpts
-              `mappend` mempty
-                { ghcOptLinkNoHsMain = toFlag (ghcOptInputFiles opts == mempty)
+  assert (Set.size wantedWays == 1) $
+    forM_ wantedWays $ \way -> do
+      let baseOpts = buildOpts way
+          linkOpts =
+            (baseOpts `mappend` linkerOpts)
+                { ghcOptLinkNoHsMain = toFlag (ghcOptInputFiles baseOpts == mempty)
                 }
               & (if withDynExe lbi then \x -> x{ghcOptRPaths = rpaths} else id)
           comp = compiler lbi
@@ -371,7 +429,7 @@ linkFLib
   -> (GhcOptions, NubListR FilePath)
   -- ^ The linker-specific GHC options, and the RPaths to include
   -- in dynamically linked binaries
-  -> Map.Map BuildWay GhcOptions
+  -> (Set.Set BuildWay, BuildWay -> GhcOptions)
   -- ^ The wanted build ways and corresponding GhcOptions that were
   -- used to compile the modules in that way.
   -> FilePath
@@ -380,7 +438,7 @@ linkFLib
   -> (GhcOptions -> IO ())
   -- ^ Run the configured GHC program
   -> IO ()
-linkFLib flib bi lbi (linkerOpts, rpaths) wantedWaysMap targetDir runGhcProg = do
+linkFLib flib bi lbi (linkerOpts, rpaths) (wantedWays, buildOpts) targetDir runGhcProg = do
   let
     comp = compiler lbi
 
@@ -412,13 +470,10 @@ linkFLib flib bi lbi (linkerOpts, rpaths) wantedWaysMap targetDir runGhcProg = d
                   else statRtsVanillaLib (rtsStaticInfo rtsInfo)
           ]
 
-    linkOpts
-      :: (BuildWay, GhcOptions)
-      -- \^ Opts for the way in which we want to build the FLib
-      -> GhcOptions
-    linkOpts (way, opts) = case foreignLibType flib of
+    linkOpts :: BuildWay -> GhcOptions
+    linkOpts way = case foreignLibType flib of
       ForeignLibNativeShared ->
-        opts
+        (buildOpts way)
           `mappend` linkerOpts
           `mappend` rtsLinkOpts way
           `mappend` mempty
@@ -439,9 +494,9 @@ linkFLib flib bi lbi (linkerOpts, rpaths) wantedWaysMap targetDir runGhcProg = d
   -- soname on supported platforms.  See also the note for
   -- @flibBuildName@.
   let buildName = flibBuildName lbi flib
-  assert (Map.size wantedWaysMap == 1) $
-    forM_ (Map.toList wantedWaysMap) $ \opts -> do
-      runGhcProg (linkOpts opts){ghcOptOutputFile = toFlag (targetDir </> buildName)}
+  assert (Set.size wantedWays == 1) $
+    forM_ wantedWays $ \way -> do
+      runGhcProg (linkOpts way){ghcOptOutputFile = toFlag (targetDir </> buildName)}
       renameFile (targetDir </> buildName) (targetDir </> flibTargetName lbi flib)
 
 -- | Calculate the RPATHs for the component we are building.