module GHC.Toolchain.PlatformDetails
    ( checkWordSize
    , checkEndianness
    , checkLeadingUnderscore
    , checkSubsectionsViaSymbols
    , checkIdentDirective
    , checkGnuNonexecStack
    ) where

import Data.List (isInfixOf)
import System.FilePath

import GHC.Platform.ArchOS

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

checkWordSize :: Cc -> M WordSize
checkWordSize :: Cc -> M WordSize
checkWordSize Cc
cc = [Char] -> M WordSize -> M WordSize
forall a. Show a => [Char] -> M a -> M a
checking [Char]
"word size" (M WordSize -> M WordSize) -> M WordSize -> M WordSize
forall a b. (a -> b) -> a -> b
$ do
    -- N.B. this is a surprisingly hard thing to check when cross-compiling.
    -- See https://stackoverflow.com/questions/4374379.
    -- To side-step this, we assume that the __SIZEOF_POINTER__ macro is
    -- available. It's technically not standard although should be available in
    -- any sane C implementation.
    output <- Cc -> [Char] -> M [Char]
preprocess Cc
cc [Char]
program
    case reverse $ lines output of
      []            -> [Char] -> M WordSize
forall a. [Char] -> M a
throwE [Char]
"test program produced no output"
      [Char]
"undefined":[[Char]]
_ -> [Char] -> M WordSize
forall a. [Char] -> M a
throwE [Char]
"__SIZEOF_POINTER__ is undefined"
      [Char]
"8":[[Char]]
_         -> WordSize -> M WordSize
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return WordSize
WS8
      [Char]
"4":[[Char]]
_         -> WordSize -> M WordSize
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return WordSize
WS4
      [[Char]]
_             -> [Char] -> M WordSize
forall a. [Char] -> M a
throwE ([Char] -> M WordSize) -> [Char] -> M WordSize
forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected output:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
output
  where
    program :: [Char]
program = [[Char]] -> [Char]
unlines
        [ [Char]
"#include <stddef.h>"
        , [Char]
"#include <inttypes.h>"
        , [Char]
"#if !defined(__SIZEOF_POINTER__)"
        , [Char]
"undefined"
        , [Char]
"#else"
        , [Char]
"__SIZEOF_POINTER__"
        , [Char]
"#endif"
        ]

checkEndianness :: Cc -> M Endianness
checkEndianness :: Cc -> M Endianness
checkEndianness Cc
cc = do
    Cc -> M Endianness
checkEndiannessParamH Cc
cc M Endianness -> M Endianness -> M Endianness
forall a. M a -> M a -> M a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Cc -> M Endianness
checkEndiannessLimitsH Cc
cc M Endianness -> M Endianness -> M Endianness
forall a. M a -> M a -> M a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Cc -> M Endianness
checkEndianness__BYTE_ORDER__ Cc
cc

checkEndiannessParamH :: Cc -> M Endianness
checkEndiannessParamH :: Cc -> M Endianness
checkEndiannessParamH Cc
cc = [Char] -> M Endianness -> M Endianness
forall a. Show a => [Char] -> M a -> M a
checking [Char]
"endianness (param.h)" (M Endianness -> M Endianness) -> M Endianness -> M Endianness
forall a b. (a -> b) -> a -> b
$ do
    output <- Cc -> [Char] -> M [Char]
preprocess Cc
cc [Char]
prog
    case reverse $ lines output of
      [Char]
"big":[[Char]]
_ -> Endianness -> M Endianness
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Endianness
BigEndian
      [Char]
"little":[[Char]]
_ -> Endianness -> M Endianness
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Endianness
LittleEndian
      [Char]
"unknown":[[Char]]
_ -> [Char] -> M Endianness
forall a. [Char] -> M a
throwE [Char]
"unknown endianness"
      [[Char]]
_ -> [Char] -> M Endianness
forall a. [Char] -> M a
throwE [Char]
"unrecognized output"
  where
    prog :: [Char]
prog = [[Char]] -> [Char]
unlines
        [ [Char]
"#include <sys/param.h>"
        , [Char]
"#if ! (defined BYTE_ORDER && defined BIG_ENDIAN \\"
        , [Char]
"   && defined LITTLE_ENDIAN && BYTE_ORDER && BIG_ENDIAN \\"
        , [Char]
"   && LITTLE_ENDIAN)"
        , [Char]
"bogus"
        , [Char]
"#elif BYTE_ORDER == BIG_ENDIAN"
        , [Char]
"big"
        , [Char]
"#elif BYTE_ORDER == LITTLE_ENDIAN"
        , [Char]
"little"
        , [Char]
"#else"
        , [Char]
"unknown"
        , [Char]
"#endif"
        ]

checkEndiannessLimitsH :: Cc -> M Endianness
checkEndiannessLimitsH :: Cc -> M Endianness
checkEndiannessLimitsH Cc
cc = [Char] -> M Endianness -> M Endianness
forall a. Show a => [Char] -> M a -> M a
checking [Char]
"endianness (limits.h)" (M Endianness -> M Endianness) -> M Endianness -> M Endianness
forall a b. (a -> b) -> a -> b
$ do
    out <- Cc -> [Char] -> M [Char]
preprocess Cc
cc [Char]
prog
    case reverse $ lines out of
      [Char]
"big":[[Char]]
_ -> Endianness -> M Endianness
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Endianness
BigEndian
      [Char]
"little":[[Char]]
_ -> Endianness -> M Endianness
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Endianness
LittleEndian
      [Char]
"unknown":[[Char]]
_ -> [Char] -> M Endianness
forall a. [Char] -> M a
throwE [Char]
"unknown endianness"
      [[Char]]
_ -> [Char] -> M Endianness
forall a. [Char] -> M a
throwE [Char]
"unrecognized output"
  where
    prog :: [Char]
prog = [[Char]] -> [Char]
unlines
        [ [Char]
"#include <limits.h>"
        , [Char]
"#if defined(_LITTLE_ENDIAN)"
        , [Char]
"little"
        , [Char]
"#elif defined(_BIG_ENDIAN)"
        , [Char]
"big"
        , [Char]
"#else"
        , [Char]
"unknown"
        , [Char]
"#endif"
        ]

checkEndianness__BYTE_ORDER__ :: Cc -> M Endianness
checkEndianness__BYTE_ORDER__ :: Cc -> M Endianness
checkEndianness__BYTE_ORDER__ Cc
cc = [Char] -> M Endianness -> M Endianness
forall a. Show a => [Char] -> M a -> M a
checking [Char]
"endianness (__BYTE_ORDER__)" (M Endianness -> M Endianness) -> M Endianness -> M Endianness
forall a b. (a -> b) -> a -> b
$ do
    out <- Cc -> [Char] -> M [Char]
preprocess Cc
cc [Char]
prog
    case reverse $ lines out of
      [Char]
"big":[[Char]]
_ -> Endianness -> M Endianness
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Endianness
BigEndian
      [Char]
"little":[[Char]]
_ -> Endianness -> M Endianness
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Endianness
LittleEndian
      [Char]
"unknown":[[Char]]
_ -> [Char] -> M Endianness
forall a. [Char] -> M a
throwE [Char]
"unknown endianness"
      [[Char]]
_ -> [Char] -> M Endianness
forall a. [Char] -> M a
throwE [Char]
"unrecognized output"
  where
    prog :: [Char]
prog = [[Char]] -> [Char]
unlines
        [ [Char]
"#include <sys/param.h>"
        , [Char]
"#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__"
        , [Char]
"little"
        , [Char]
"#elif __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__"
        , [Char]
"big"
        , [Char]
"#else"
        , [Char]
"unknown"
        , [Char]
"#endif"
        ]



checkLeadingUnderscore :: Cc -> Nm -> M Bool
checkLeadingUnderscore :: Cc -> Nm -> M Bool
checkLeadingUnderscore Cc
cc Nm
nm = [Char] -> M Bool -> M Bool
forall a. Show a => [Char] -> M a -> M a
checking [Char]
ctxt (M Bool -> M Bool) -> M Bool -> M Bool
forall a b. (a -> b) -> a -> b
$ ([Char] -> M Bool) -> M Bool
forall a. ([Char] -> M a) -> M a
withTempDir (([Char] -> M Bool) -> M Bool) -> ([Char] -> M Bool) -> M Bool
forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
    let test_o :: [Char]
test_o = [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"test.o"
    Cc -> [Char] -> [Char] -> M ()
compileC Cc
cc [Char]
test_o [Char]
prog
    out <- Program -> [[Char]] -> M [Char]
readProgramStdout (Nm -> Program
nmProgram Nm
nm) [[Char]
test_o]
    return $ "_func" `isInfixOf` out
  where
    prog :: [Char]
prog = [Char]
"int func(void) { return 0; }"
    ctxt :: [Char]
ctxt = [Char]
"whether symbols have leading underscores"

checkSubsectionsViaSymbols :: ArchOS -> Cc -> M Bool
checkSubsectionsViaSymbols :: ArchOS -> Cc -> M Bool
checkSubsectionsViaSymbols ArchOS
archos Cc
cc =
  case ArchOS -> Arch
archOS_arch ArchOS
archos of
    Arch
ArchAArch64 ->
      -- subsections via symbols is busted on arm64
      -- TODO: ^ is this comment up to date?
      Bool -> M Bool
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Arch
_ ->
      [Char] -> [Char] -> Cc -> M Bool
testCompile
        [Char]
"whether .subsections-via-symbols directive is supported"
        ([Char] -> [Char]
asmStmt [Char]
".subsections_via_symbols") Cc
cc

checkIdentDirective :: Cc -> M Bool
checkIdentDirective :: Cc -> M Bool
checkIdentDirective =
    [Char] -> [Char] -> Cc -> M Bool
testCompile
      [Char]
"whether the .ident directive is supported"
      ([Char] -> [Char]
asmStmt [Char]
".ident \"GHC x.y.z\"")

checkGnuNonexecStack :: ArchOS -> Cc -> M Bool
checkGnuNonexecStack :: ArchOS -> Cc -> M Bool
checkGnuNonexecStack ArchOS
archOs =
    [Char] -> [Char] -> Cc -> M Bool
testCompile
      [Char]
"whether GNU non-executable stack directives are supported"
      [Char]
prog
  where
    progbits :: [Char]
progbits = case ArchOS -> Arch
archOS_arch ArchOS
archOs of
                 ArchARM{} -> [Char]
"%progbits" -- See #13937
                 Arch
_         -> [Char]
"@progbits"

    prog :: [Char]
prog = [[Char]] -> [Char]
unlines [ [Char] -> [Char]
asmStmt ([Char]
".section .note.GNU-stack,\"\","[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
progbits)
                   , [Char] -> [Char]
asmStmt [Char]
".section .text"
                   ]

asmStmt :: String -> String
asmStmt :: [Char] -> [Char]
asmStmt [Char]
s = [Char]
"__asm__(\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char -> [Char]) -> [Char] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Char -> [Char]
escape [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\");"
  where
    escape :: Char -> [Char]
escape Char
'"' = [Char]
"\\\""
    escape Char
c   = [Char
c]

-- | Try compiling a program, returning 'True' if successful.
testCompile :: String -> String -> Cc -> M Bool
testCompile :: [Char] -> [Char] -> Cc -> M Bool
testCompile [Char]
what [Char]
program Cc
cc = [Char] -> M Bool -> M Bool
forall a. Show a => [Char] -> M a -> M a
checking [Char]
what (M Bool -> M Bool) -> M Bool -> M Bool
forall a b. (a -> b) -> a -> b
$ ([Char] -> M Bool) -> M Bool
forall a. ([Char] -> M a) -> M a
withTempDir (([Char] -> M Bool) -> M Bool) -> ([Char] -> M Bool) -> M Bool
forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
    let test_o :: [Char]
test_o = [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"test.o"
    (Bool
True Bool -> M () -> M Bool
forall a b. a -> M b -> M a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Cc -> [Char] -> [Char] -> M ()
compileC Cc
cc [Char]
test_o [Char]
program) M Bool -> M Bool -> M Bool
forall a. M a -> M a -> M a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> M Bool
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False