Skip to content

Commit

Permalink
Refactor the linking invocations from gbuild/buildOrReplLib
Browse files Browse the repository at this point in the history
This is the third part of the refactor of gbuild and buildOrReplLib (haskell#9389).
It re-works the linker invocations, focusing on preserving existing
behaviour before simplifying or fixing bugs any further.

Follows the spirit of the two previous commits, with the end goal of (haskell#9389)
  • Loading branch information
alt-romes committed Jan 18, 2024
1 parent 8f860dd commit c906382
Show file tree
Hide file tree
Showing 11 changed files with 1,396 additions and 1,480 deletions.
2 changes: 0 additions & 2 deletions Cabal/Cabal.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -337,8 +337,6 @@ library
Distribution.Simple.GHC.Build.Link
Distribution.Simple.GHC.Build.Modules
Distribution.Simple.GHC.Build.Utils
Distribution.Simple.GHC.BuildGeneric
Distribution.Simple.GHC.BuildOrRepl
Distribution.Simple.GHC.EnvironmentParser
Distribution.Simple.GHC.Internal
Distribution.Simple.GHC.ImplInfo
Expand Down
43 changes: 33 additions & 10 deletions Cabal/src/Distribution/Simple/Build/Monad.hs
Original file line number Diff line number Diff line change
@@ -1,14 +1,18 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}

module Distribution.Simple.Build.Monad
( BuildM (..)
( -- * A Monad for building components
BuildM (BuildM)
, runBuildM
, PreBuildComponentInputs (..)

-- * A few queries on @'BuildM'@
-- * Queries over the component being built
, buildVerbosity
, buildWhat
, buildComponent
, buildIsLib
, buildCLBI
, buildBI
, buildLBI
Expand All @@ -26,14 +30,14 @@ where

import Control.Monad.Reader

import Distribution.Simple.Compiler
import Distribution.Simple.Setup (BuildingWhat (..), buildingWhatDistPref, buildingWhatVerbosity)
import Distribution.Types.BuildInfo
import Distribution.Types.Component
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.LocalBuildInfo
import Distribution.Types.TargetInfo
import Distribution.Verbosity
import Distribution.Types.Component
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.BuildInfo
import Distribution.Simple.Compiler

-- | The information required for a build computation (@'BuildM'@)
-- which is available right before building each component, i.e. the pre-build
Expand All @@ -48,8 +52,16 @@ data PreBuildComponentInputs = PreBuildComponentInputs
}

-- | Computations carried out in the context of building a component (e.g. @'buildAllExtraSources'@)
newtype BuildM a = BuildM (PreBuildComponentInputs -> IO a)
deriving (Functor, Applicative, Monad, MonadReader PreBuildComponentInputs, MonadIO) via ReaderT PreBuildComponentInputs IO
newtype BuildM a = BuildM' (ReaderT PreBuildComponentInputs IO a)
deriving (Functor, Applicative, Monad, MonadReader PreBuildComponentInputs, MonadIO)

-- Ideally we'd use deriving via ReaderT PreBuildComponentInputs IO, but ghc 8.4 doesn't support it.

-- | Construct a t'BuildM' action from an IO function on 'PreBuildComponentInputs'.
pattern BuildM :: (PreBuildComponentInputs -> IO a) -> BuildM a
pattern BuildM f = BuildM' (ReaderT f)

{-# COMPLETE BuildM #-}

-- | Run a 'BuildM' action, i.e. a computation in the context of building a component.
runBuildM :: BuildingWhat -> LocalBuildInfo -> TargetInfo -> BuildM a -> IO a
Expand All @@ -72,6 +84,16 @@ buildComponent :: BuildM Component
buildComponent = asks (targetComponent . targetInfo)
{-# INLINE buildComponent #-}

-- | Is the @'Component'@ being built a @'Library'@?
buildIsLib :: BuildM Bool
buildIsLib = do
component <- buildComponent
let isLib
| CLib{} <- component = True
| otherwise = False
return isLib
{-# INLINE buildIsLib #-}

-- | Get the @'ComponentLocalBuildInfo'@ for the component being built.
buildCLBI :: BuildM ComponentLocalBuildInfo
buildCLBI = asks (targetCLBI . targetInfo)
Expand All @@ -87,11 +109,12 @@ buildLBI :: BuildM LocalBuildInfo
buildLBI = asks localBuildInfo
{-# INLINE buildLBI #-}

-- | Get the @'Compiler'@ being used to build the component.
buildCompiler :: BuildM Compiler
buildCompiler = compiler <$> buildLBI
{-# INLINE buildCompiler #-}

-- | Get the @'TargetInfo'@ of the current component being built.
buildTarget :: BuildM TargetInfo
buildTarget = asks targetInfo

{-# INLINE buildTarget #-}
111 changes: 57 additions & 54 deletions Cabal/src/Distribution/Simple/GHC.hs
Original file line number Diff line number Diff line change
Expand Up @@ -89,10 +89,12 @@ import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import Distribution.Package
import Distribution.PackageDescription as PD
import Distribution.Pretty
import Distribution.Simple.Build.Monad (runBuildM)
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.Flag (Flag (..), toFlag)
import qualified Distribution.Simple.GHC.Build as GHC
import Distribution.Simple.GHC.Build.Utils
import Distribution.Simple.GHC.EnvironmentParser
import Distribution.Simple.GHC.ImplInfo
Expand All @@ -102,7 +104,6 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.Program
import Distribution.Simple.Program.Builtin (runghcProgram)
import Distribution.Types.TargetInfo
import Distribution.Simple.Program.GHC
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import qualified Distribution.Simple.Program.Strip as Strip
Expand All @@ -112,6 +113,7 @@ import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.ParStrat
import Distribution.Types.TargetInfo
import Distribution.Utils.NubList
import Distribution.Verbosity
import Distribution.Version
Expand All @@ -131,13 +133,10 @@ import System.FilePath
)
import qualified System.Info
#ifndef mingw32_HOST_OS
import Distribution.Simple.GHC.Build.Utils (flibBuildName)
import System.Directory (renameFile)
import System.Posix (createSymbolicLink)
#endif /* mingw32_HOST_OS */

import Distribution.Simple.GHC.BuildGeneric (GBuildMode (..), gbuild)
import Distribution.Simple.GHC.BuildOrRepl (buildOrReplLib)
import Distribution.Simple.Setup (BuildingWhat (..))
import Distribution.Simple.Setup.Build

Expand Down Expand Up @@ -567,7 +566,8 @@ buildLib
-> Library
-> ComponentLocalBuildInfo
-> IO ()
buildLib = buildOrReplLib . BuildNormal
buildLib flags numJobs pkg lbi lib clbi =
runBuildM (BuildNormal flags) lbi (TargetInfo clbi (CLib lib)) (GHC.build numJobs pkg)

replLib
:: ReplFlags
Expand All @@ -577,7 +577,8 @@ replLib
-> Library
-> ComponentLocalBuildInfo
-> IO ()
replLib = buildOrReplLib . BuildRepl
replLib flags numJobs pkg lbi lib clbi =
runBuildM (BuildRepl flags) lbi (TargetInfo clbi (CLib lib)) (GHC.build numJobs pkg)

-- | Start a REPL without loading any source files.
startInterpreter
Expand Down Expand Up @@ -609,7 +610,8 @@ buildFLib
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO ()
buildFLib v njobs pkg lbi = gbuild (BuildNormal mempty{buildVerbosity = toFlag v}) njobs pkg lbi . GBuildFLib
buildFLib v njobs pkg lbi flib clbi =
runBuildM (BuildNormal mempty{buildVerbosity = toFlag v}) lbi (TargetInfo clbi (CFLib flib)) (GHC.build njobs pkg)

replFLib
:: ReplFlags
Expand All @@ -619,8 +621,8 @@ replFLib
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO ()
replFLib replFlags njobs pkg lbi =
gbuild (BuildRepl replFlags) njobs pkg lbi . GReplFLib replFlags
replFLib replFlags njobs pkg lbi flib clbi =
runBuildM (BuildRepl replFlags) lbi (TargetInfo clbi (CFLib flib)) (GHC.build njobs pkg)

-- | Build an executable with GHC.
buildExe
Expand All @@ -631,7 +633,8 @@ buildExe
-> Executable
-> ComponentLocalBuildInfo
-> IO ()
buildExe v njobs pkg lbi = gbuild (BuildNormal mempty{buildVerbosity = toFlag v}) njobs pkg lbi . GBuildExe
buildExe v njobs pkg lbi exe clbi =
runBuildM (BuildNormal mempty{buildVerbosity = toFlag v}) lbi (TargetInfo clbi (CExe exe)) (GHC.build njobs pkg)

replExe
:: ReplFlags
Expand All @@ -641,8 +644,8 @@ replExe
-> Executable
-> ComponentLocalBuildInfo
-> IO ()
replExe replFlags njobs pkg lbi =
gbuild (BuildRepl replFlags) njobs pkg lbi . GReplExe replFlags
replExe replFlags njobs pkg lbi exe clbi =
runBuildM (BuildRepl replFlags) lbi (TargetInfo clbi (CExe exe)) (GHC.build njobs pkg)

-- | Extracts a String representing a hash of the ABI of a built
-- library. It can fail if the library has not yet been built.
Expand Down Expand Up @@ -724,7 +727,7 @@ installExe
exe = do
createDirectoryIfMissingVerbose verbosity True binDir
let exeName' = unUnqualComponentName $ exeName exe
exeFileName = exeTargetName (hostPlatform lbi) exe
exeFileName = exeTargetName (hostPlatform lbi) (exeName exe)
fixedExeBaseName = progprefix ++ exeName' ++ progsuffix
installBinary dest = do
installExecutableFile
Expand Down Expand Up @@ -834,47 +837,47 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do
whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName
whenShared $
if
-- The behavior for "extra-bundled-libraries" changed in version 2.5.0.
-- See ghc issue #15837 and Cabal PR #5855.
| specVersion pkg < CabalSpecV3_0 -> do
sequence_
[ installShared
builtDir
dynlibTargetDir
(mkGenericSharedLibName platform compiler_id (l ++ f))
| l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)
, f <- "" : extraDynLibFlavours (libBuildInfo lib)
]
| otherwise -> do
sequence_
[ installShared
builtDir
dynlibTargetDir
( mkGenericSharedLibName
platform
compiler_id
(getHSLibraryName uid ++ f)
)
| f <- "" : extraDynLibFlavours (libBuildInfo lib)
]
sequence_
[ do
files <- getDirectoryContents builtDir
let l' =
mkGenericSharedBundledLibName
platform
compiler_id
l
forM_ files $ \file ->
when (l' `isPrefixOf` file) $ do
isFile <- doesFileExist (builtDir </> file)
when isFile $ do
installShared
builtDir
dynlibTargetDir
file
| l <- extraBundledLibs (libBuildInfo lib)
]
-- The behavior for "extra-bundled-libraries" changed in version 2.5.0.
-- See ghc issue #15837 and Cabal PR #5855.
| specVersion pkg < CabalSpecV3_0 -> do
sequence_
[ installShared
builtDir
dynlibTargetDir
(mkGenericSharedLibName platform compiler_id (l ++ f))
| l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)
, f <- "" : extraDynLibFlavours (libBuildInfo lib)
]
| otherwise -> do
sequence_
[ installShared
builtDir
dynlibTargetDir
( mkGenericSharedLibName
platform
compiler_id
(getHSLibraryName uid ++ f)
)
| f <- "" : extraDynLibFlavours (libBuildInfo lib)
]
sequence_
[ do
files <- getDirectoryContents builtDir
let l' =
mkGenericSharedBundledLibName
platform
compiler_id
l
forM_ files $ \file ->
when (l' `isPrefixOf` file) $ do
isFile <- doesFileExist (builtDir </> file)
when isFile $ do
installShared
builtDir
dynlibTargetDir
file
| l <- extraBundledLibs (libBuildInfo lib)
]
where
builtDir = componentBuildDir lbi clbi

Expand Down
Loading

0 comments on commit c906382

Please sign in to comment.