{-# 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 Prelude ()
import Distribution.Compat.Prelude

import Distribution.Simple.Compiler (arResponseFilesSupported)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))
import Distribution.Simple.Program.ResponseFile
         ( withResponseFile )
import Distribution.Simple.Program.Run
         ( ProgramInvocation, programInvocation, multiStageProgramInvocation
         , runProgramInvocation )
import Distribution.Simple.Program.Types
         ( ConfiguredProgram(..) )
import Distribution.Simple.Setup
         ( fromFlagOrDefault, 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 (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