    {-# LANGUAGE NamedFieldPuns #-}
    {-# LANGUAGE CPP #-}

    module GHC.Toolchain.Tools.MergeObjs ( MergeObjs(..), findMergeObjs ) where

    import Control.Monad
    import Data.List (isInfixOf)
    import System.FilePath

    import GHC.Toolchain.Prelude
    import GHC.Toolchain.Utils
    import GHC.Toolchain.Program
    import GHC.Toolchain.Tools.Cc
    import GHC.Toolchain.Tools.Link
    import GHC.Toolchain.Tools.Nm

    -- | Configuration on how the C compiler can be used to link
    data MergeObjs = MergeObjs { MergeObjs -> Program
    mergeObjsProgram :: Program
                               , MergeObjs -> Bool
    mergeObjsSupportsResponseFiles :: Bool
                               }
        deriving (Int -> MergeObjs -> ShowS
    [MergeObjs] -> ShowS
    MergeObjs -> String
    (Int -> MergeObjs -> ShowS)
    -> (MergeObjs -> String)
    -> ([MergeObjs] -> ShowS)
    -> Show MergeObjs
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> MergeObjs -> ShowS
    showsPrec :: Int -> MergeObjs -> ShowS
    $cshow :: MergeObjs -> String
    show :: MergeObjs -> String
    $cshowList :: [MergeObjs] -> ShowS
    showList :: [MergeObjs] -> ShowS
    Show, ReadPrec [MergeObjs]
    ReadPrec MergeObjs
    Int -> ReadS MergeObjs
    ReadS [MergeObjs]
    (Int -> ReadS MergeObjs)
    -> ReadS [MergeObjs]
    -> ReadPrec MergeObjs
    -> ReadPrec [MergeObjs]
    -> Read MergeObjs
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    $creadsPrec :: Int -> ReadS MergeObjs
    readsPrec :: Int -> ReadS MergeObjs
    $creadList :: ReadS [MergeObjs]
    readList :: ReadS [MergeObjs]
    $creadPrec :: ReadPrec MergeObjs
    readPrec :: ReadPrec MergeObjs
    $creadListPrec :: ReadPrec [MergeObjs]
    readListPrec :: ReadPrec [MergeObjs]
    Read, MergeObjs -> MergeObjs -> Bool
    (MergeObjs -> MergeObjs -> Bool)
    -> (MergeObjs -> MergeObjs -> Bool) -> Eq MergeObjs
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: MergeObjs -> MergeObjs -> Bool
    == :: MergeObjs -> MergeObjs -> Bool
    $c/= :: MergeObjs -> MergeObjs -> Bool
    /= :: MergeObjs -> MergeObjs -> Bool
    Eq, Eq MergeObjs
    Eq MergeObjs =>
    (MergeObjs -> MergeObjs -> Ordering)
    -> (MergeObjs -> MergeObjs -> Bool)
    -> (MergeObjs -> MergeObjs -> Bool)
    -> (MergeObjs -> MergeObjs -> Bool)
    -> (MergeObjs -> MergeObjs -> Bool)
    -> (MergeObjs -> MergeObjs -> MergeObjs)
    -> (MergeObjs -> MergeObjs -> MergeObjs)
    -> Ord MergeObjs
    MergeObjs -> MergeObjs -> Bool
    MergeObjs -> MergeObjs -> Ordering
    MergeObjs -> MergeObjs -> MergeObjs
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: MergeObjs -> MergeObjs -> Ordering
    compare :: MergeObjs -> MergeObjs -> Ordering
    $c< :: MergeObjs -> MergeObjs -> Bool
    < :: MergeObjs -> MergeObjs -> Bool
    $c<= :: MergeObjs -> MergeObjs -> Bool
    <= :: MergeObjs -> MergeObjs -> Bool
    $c> :: MergeObjs -> MergeObjs -> Bool
    > :: MergeObjs -> MergeObjs -> Bool
    $c>= :: MergeObjs -> MergeObjs -> Bool
    >= :: MergeObjs -> MergeObjs -> Bool
    $cmax :: MergeObjs -> MergeObjs -> MergeObjs
    max :: MergeObjs -> MergeObjs -> MergeObjs
    $cmin :: MergeObjs -> MergeObjs -> MergeObjs
    min :: MergeObjs -> MergeObjs -> MergeObjs
    Ord)

    findMergeObjs :: ProgOpt -> Cc -> CcLink -> Nm -> M MergeObjs
    findMergeObjs :: ProgOpt -> Cc -> CcLink -> Nm -> M MergeObjs
    findMergeObjs ProgOpt
    progOpt Cc
    cc CcLink
    ccLink Nm
    nm = String -> M MergeObjs -> M MergeObjs
    forall a. Show a => String -> M a -> M a
    checking String
    "for linker for merging objects" (M MergeObjs -> M MergeObjs) -> M MergeObjs -> M MergeObjs
    forall a b. (a -> b) -> a -> b
    $ do
        prog <- String -> ProgOpt -> [String] -> M Program
    findProgram String
    "linker for merging objects" ProgOpt
    progOpt [String
    "ld"]
        let mo = Program
    prog Program -> (Program -> Program) -> Program
    forall a b. a -> (a -> b) -> b
    & Lens Program [String]
    _prgFlags Lens Program [String] -> String -> Program -> Program
    forall a b. Lens a [b] -> b -> a -> a
    %++ String
    "-r"
        checkMergingWorks cc nm mo
        checkForGoldT22266 cc ccLink mo
        supportsResponseFiles <- checkSupportsResponseFiles cc nm mo
        return (MergeObjs mo supportsResponseFiles)

    checkMergingWorks :: Cc -> Nm -> Program -> M ()
    checkMergingWorks :: Cc -> Nm -> Program -> M ()
    checkMergingWorks Cc
    cc Nm
    nm Program
    mergeObjs =
        String -> M () -> M ()
    forall a. Show a => String -> M a -> M a
    checking String
    "whether object merging works" (M () -> M ()) -> M () -> M ()
    forall a b. (a -> b) -> a -> b
    $ (String -> M ()) -> M ()
    forall a. (String -> M a) -> M a
    withTempDir ((String -> M ()) -> M ()) -> (String -> M ()) -> M ()
    forall a b. (a -> b) -> a -> b
    $ \String
    dir -> do
            let fo :: ShowS
    fo String
    s = String
    dir String -> ShowS
    </> String
    s String -> ShowS
    <.> String
    "o"
            Cc -> String -> String -> M ()
    compileC Cc
    cc (ShowS
    fo String
    "a") String
    "int funA(int x) { return x; }"
            Cc -> String -> String -> M ()
    compileC Cc
    cc (ShowS
    fo String
    "b") String
    "int funB(int x) { return x; }"
            Program -> [String] -> M ()
    callProgram Program
    mergeObjs [ShowS
    fo String
    "a", ShowS
    fo String
    "b", String
    "-o", ShowS
    fo String
    "out"]
            out <- Program -> [String] -> M String
    readProgramStdout (Nm -> Program
    nmProgram Nm
    nm) [ShowS
    fo String
    "out"]
            let ok = (String -> Bool) -> [String] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isInfixOf` String
    out) [String
    "funA", String
    "funB"]
            unless ok $ throwE "merged objects is missing symbols"

    checkSupportsResponseFiles :: Cc -> Nm -> Program -> M Bool
    checkSupportsResponseFiles :: Cc -> Nm -> Program -> M Bool
    checkSupportsResponseFiles Cc
    cc Nm
    nm Program
    mergeObjs = String -> M Bool -> M Bool
    forall a. Show a => String -> M a -> M a
    checking String
    "whether the merge objects tool supports response files" (M Bool -> M Bool) -> M Bool -> M Bool
    forall a b. (a -> b) -> a -> b
    $
      (String -> M Bool) -> M Bool
    forall a. (String -> M a) -> M a
    withTempDir ((String -> M Bool) -> M Bool) -> (String -> M Bool) -> M Bool
    forall a b. (a -> b) -> a -> b
    $ \String
    dir -> do
        -- Like 'checkMergingWorks', but pass the arguments in a response file
        let fo :: ShowS
    fo String
    s     = String
    dir String -> ShowS
    </> String
    s String -> ShowS
    <.> String
    "o"
            args_txt :: String
    args_txt = String
    dir String -> ShowS
    </> String
    "args.txt"
        Cc -> String -> String -> M ()
    compileC Cc
    cc (ShowS
    fo String
    "a") String
    "int funA(int x) { return x; }"
        Cc -> String -> String -> M ()
    compileC Cc
    cc (ShowS
    fo String
    "b") String
    "int funB(int x) { return x; }"
        String -> String -> M ()
    writeFile String
    args_txt ([String] -> String
    unlines [ShowS
    fo String
    "a", ShowS
    fo String
    "b", String
    "-o", ShowS
    fo String
    "out"])
        Program -> [String] -> M ()
    callProgram Program
    mergeObjs [String
    "@" String -> ShowS
    forall a. Semigroup a => a -> a -> a
    <> String
    args_txt]
        out <- Program -> [String] -> M String
    readProgramStdout (Nm -> Program
    nmProgram Nm
    nm) [ShowS
    fo String
    "out"]
        return $ all (`isInfixOf` out) ["funA", "funB"]

    -- Test for binutils #22266. This bug manifested as GHC bug #14328 (see also:
    -- #14675, #14291).
    -- Uses test from
    -- https://sourceware.org/git/gitweb.cgi?p=binutils-gdb.git;h=033bfb739b525703bfe23f151d09e9beee3a2afe
    checkForGoldT22266 :: Cc -> CcLink -> Program -> M ()
    checkForGoldT22266 :: Cc -> CcLink -> Program -> M ()
    checkForGoldT22266 Cc
    cc CcLink
    ccLink Program
    mergeObjs = do
        version <- String -> M String -> M String
    forall a. Show a => String -> M a -> M a
    checking String
    "for ld.gold object merging bug (binutils #22266)" (M String -> M String) -> M String -> M String
    forall a b. (a -> b) -> a -> b
    $
            Program -> [String] -> M String
    readProgramStdout Program
    mergeObjs [String
    "--version"]
        when ("gold" `isInfixOf` version) check_it
      where
        check_it :: M ()
    check_it =
            String -> M () -> M ()
    forall a. Show a => String -> M a -> M a
    checking String
    "for ld.gold object merging bug (binutils #22266)" (M () -> M ()) -> M () -> M ()
    forall a b. (a -> b) -> a -> b
    $
            M () -> M () -> M ()
    forall a. M a -> M a -> M a
    ifCrossCompiling (String -> M ()
    logInfo String
    "Cross-compiling, assuming linker is unaffected") (M () -> M ()) -> M () -> M ()
    forall a b. (a -> b) -> a -> b
    $
            (String -> M ()) -> M ()
    forall a. (String -> M a) -> M a
    withTempDir ((String -> M ()) -> M ()) -> (String -> M ()) -> M ()
    forall a b. (a -> b) -> a -> b
    $ \String
    dir -> do
                let f :: ShowS
    f String
    s = String
    dir String -> ShowS
    </> String
    s
                    link_script :: String
    link_script = ShowS
    f String
    "link.t"
                    a_o :: String
    a_o = ShowS
    f String
    "a.o"
                    merged_o :: String
    merged_o = ShowS
    f String
    "merged.o"
                    main_o :: String
    main_o = ShowS
    f String
    "main.o"
                    exe :: String
    exe = ShowS
    f String
    "main"
                Cc -> String -> String -> M ()
    compileC Cc
    cc String
    a_o String
    progA
                String -> String -> M ()
    writeFile String
    link_script String
    ldScript
                Program -> [String] -> M ()
    callProgram Program
    mergeObjs
                    [String
    "-T", String
    link_script, String
    a_o, String
    "-o", String
    merged_o]
                Cc -> String -> String -> M ()
    compileC Cc
    cc String
    main_o String
    progMain
                Program -> [String] -> M ()
    callProgram (CcLink -> Program
    ccLinkProgram CcLink
    ccLink)
                    [String
    "-o", String
    exe, String
    merged_o, String
    main_o]
                Program -> [String] -> M ()
    callProgram (String -> [String] -> Program
    Program String
    exe []) []

        progA :: String
    progA = [String] -> String
    unlines
            [ String
    "__attribute__((section(\".data.a\")))"
            , String
    "static int int_from_a_1 = 0x11223344;"
            , String
    ""
            , String
    "__attribute__((section(\".data.rel.ro.a\")))"
            , String
    "int *p_int_from_a_2 = &int_from_a_1;"
            , String
    ""
            , String
    "const char *hello (void);"
            , String
    ""
            , String
    "const char * hello (void)"
            , String
    "{ return \"XXXHello, world!\" + 3; }"
            ]

        progMain :: String
    progMain = [String] -> String
    unlines
            [ String
    "#include <stdlib.h>"
            , String
    "#include <string.h>"
            , String
    ""
            , String
    "extern int *p_int_from_a_2;"
            , String
    "extern const char *hello (void);"
            , String
    ""
            , String
    "int main (void) {"
            , String
    "  if (*p_int_from_a_2 != 0x11223344)"
            , String
    "    abort ();"
            , String
    "  if (strcmp(hello(), \"Hello, world!\") != 0)"
            , String
    "    abort ();"
            , String
    "  return 0;"
            , String
    "}"
            ]

        ldScript :: String
    ldScript = [String] -> String
    unlines
            [ String
    "SECTIONS {"
            , String
    "  .text : { *(.text*) }"
            , String
    "  .rodata : { *(.rodata .rodata.* .gnu.linkonce.r.*) }"
            , String
    "  .data.rel.ro : { *(.data.rel.ro*) }"
            , String
    "  .data : { *(.data*) }"
            , String
    "  .bss : { *(.bss*) }"
            , String
    "}"
            ]