{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Simple.Program.Ld
-- Copyright   :  Duncan Coutts 2009
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module provides an library interface to the @ld@ linker program.
module Distribution.Simple.Program.Ld
  ( combineObjectFiles
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Simple.Compiler (arResponseFilesSupported)
import Distribution.Simple.Flag
  ( fromFlagOrDefault
  )
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))
import Distribution.Simple.Program.ResponseFile
  ( withResponseFile
  )
import Distribution.Simple.Program.Run
  ( ProgramInvocation
  , multiStageProgramInvocation
  , programInvocation
  , runProgramInvocation
  )
import Distribution.Simple.Program.Types
  ( ConfiguredProgram (..)
  )
import Distribution.Simple.Setup.Config
  ( configUseResponseFiles
  )
import Distribution.Simple.Utils
  ( defaultTempFileOptions
  )
import Distribution.Verbosity
  ( Verbosity
  )

import System.Directory
  ( renameFile
  )
import System.FilePath
  ( takeDirectory
  , (<.>)
  )

-- | Call @ld -r@ to link a bunch of object files together.
combineObjectFiles
  :: Verbosity
  -> LocalBuildInfo
  -> ConfiguredProgram
  -> FilePath
  -> [FilePath]
  -> IO ()
combineObjectFiles :: Verbosity
-> LocalBuildInfo
-> ConfiguredProgram
-> FilePath
-> [FilePath]
-> IO ()
combineObjectFiles Verbosity
verbosity LocalBuildInfo
lbi ConfiguredProgram
ld FilePath
target [FilePath]
files = do
  -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is,
  -- if we have more object files than fit on a single command line then we
  -- have a slight problem. What we have to do is link files in batches into
  -- a temp object file and then include that one in the next batch.

  let simpleArgs :: [FilePath]
simpleArgs = [FilePath
"-r", FilePath
"-o", FilePath
target]

      initialArgs :: [FilePath]
initialArgs = [FilePath
"-r", FilePath
"-o", FilePath
target]
      middleArgs :: [FilePath]
middleArgs = [FilePath
"-r", FilePath
"-o", FilePath
target, FilePath
tmpfile]
      finalArgs :: [FilePath]
finalArgs = [FilePath]
middleArgs

      simple :: ProgramInvocation
simple = ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation ConfiguredProgram
ld [FilePath]
simpleArgs
      initial :: ProgramInvocation
initial = ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation ConfiguredProgram
ld [FilePath]
initialArgs
      middle :: ProgramInvocation
middle = ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation ConfiguredProgram
ld [FilePath]
middleArgs
      final :: ProgramInvocation
final = ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation ConfiguredProgram
ld [FilePath]
finalArgs

      targetDir :: FilePath
targetDir = FilePath -> FilePath
takeDirectory FilePath
target

      invokeWithResponesFile :: FilePath -> ProgramInvocation
      invokeWithResponesFile :: FilePath -> ProgramInvocation
invokeWithResponesFile FilePath
atFile =
        ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation ConfiguredProgram
ld ([FilePath] -> ProgramInvocation)
-> [FilePath] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$ [FilePath]
simpleArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [Char
'@' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
atFile]

      oldVersionManualOverride :: Bool
oldVersionManualOverride =
        Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag Bool
configUseResponseFiles (ConfigFlags -> Flag Bool) -> ConfigFlags -> Flag Bool
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> ConfigFlags
configFlags LocalBuildInfo
lbi
      -- Whether ghc's ar supports response files is a good proxy for
      -- whether ghc's ld supports them as well.
      responseArgumentsNotSupported :: Bool
responseArgumentsNotSupported =
        Bool -> Bool
not (Compiler -> Bool
arResponseFilesSupported (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi))

  if Bool
oldVersionManualOverride Bool -> Bool -> Bool
|| Bool
responseArgumentsNotSupported
    then [ProgramInvocation] -> IO ()
run ([ProgramInvocation] -> IO ()) -> [ProgramInvocation] -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgramInvocation
-> (ProgramInvocation, ProgramInvocation, ProgramInvocation)
-> [FilePath]
-> [ProgramInvocation]
multiStageProgramInvocation ProgramInvocation
simple (ProgramInvocation
initial, ProgramInvocation
middle, ProgramInvocation
final) [FilePath]
files
    else Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> Maybe TextEncoding
-> [FilePath]
-> (FilePath -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> Maybe TextEncoding
-> [FilePath]
-> (FilePath -> IO a)
-> IO a
withResponseFile Verbosity
verbosity TempFileOptions
defaultTempFileOptions FilePath
targetDir FilePath
"ld.rsp" Maybe TextEncoding
forall a. Maybe a
Nothing [FilePath]
files ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
      \FilePath
path -> Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (ProgramInvocation -> IO ()) -> ProgramInvocation -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ProgramInvocation
invokeWithResponesFile FilePath
path
  where
    tmpfile :: FilePath
tmpfile = FilePath
target FilePath -> FilePath -> FilePath
<.> FilePath
"tmp" -- perhaps should use a proper temp file
    run :: [ProgramInvocation] -> IO ()
    run :: [ProgramInvocation] -> IO ()
run [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    run [ProgramInvocation
inv] = Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
inv
    run (ProgramInvocation
inv : [ProgramInvocation]
invs) = do
      Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
inv
      FilePath -> FilePath -> IO ()
renameFile FilePath
target FilePath
tmpfile
      [ProgramInvocation] -> IO ()
run [ProgramInvocation]
invs