{-# 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.gold", 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
"}"
        ]