module GHC.Toolchain.CheckArm ( findArmIsa ) where

import Data.List (isInfixOf)
import Data.Maybe (catMaybes)
import Control.Monad.IO.Class
import System.Process

import GHC.Platform.ArchOS

import GHC.Toolchain.Prelude
import GHC.Toolchain.Tools.Cc

-- | Awkwardly, ARM triples sometimes contain insufficient information about
-- the platform. Consequently we instead extract this information from the
-- toolchain.
findArmIsa :: Cc -> M Arch
findArmIsa :: Cc -> M Arch
findArmIsa Cc
cc = do
    isa <- M ArmISA
checkIsa
    abi <- checkAbi
    exts <- catMaybes <$> mapM checkExtension extensions
    let arch = ArmISA -> [ArmISAExt] -> ArmABI -> Arch
ArchARM ArmISA
isa [ArmISAExt]
exts ArmABI
abi
    raspbianHack arch
  where
    checkIsa :: M ArmISA
checkIsa = String -> M ArmISA -> M ArmISA
forall a. Show a => String -> M a -> M a
checking String
"ARM ISA" (M ArmISA -> M ArmISA) -> M ArmISA -> M ArmISA
forall a b. (a -> b) -> a -> b
$ do
        arch <- String -> String
lastLine (String -> String) -> M String -> M String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cc -> String -> M String
preprocess Cc
cc String
archTestProgram
        case arch of
          String
_ | String
arch String -> String -> Bool
forall a. Ord a => a -> a -> Bool
< String
"6" -> String -> M ArmISA
forall a. String -> M a
throwE String
"pre-ARMv6 is not supported"
          Char
'6':String
_ -> ArmISA -> M ArmISA
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return ArmISA
ARMv6
          Char
'7':String
_ -> ArmISA -> M ArmISA
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return ArmISA
ARMv7
          String
_ -> String -> M ArmISA
forall a. String -> M a
throwE String
"unknown ARM platform"

    checkAbi :: M ArmABI
checkAbi = String -> M ArmABI -> M ArmABI
forall a. Show a => String -> M a -> M a
checking String
"ARM ABI" (M ArmABI -> M ArmABI) -> M ArmABI -> M ArmABI
forall a b. (a -> b) -> a -> b
$ do
        out <- (String -> String) -> M String -> M String
forall a b. (a -> b) -> M a -> M b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
lastLine (M String -> M String) -> M String -> M String
forall a b. (a -> b) -> a -> b
$ Cc -> String -> M String
preprocess Cc
cc (String -> M String) -> String -> M String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [ String
"#if defined(__ARM_PCS_VFP)"
            , String
"HARD"
            , String
"#elif defined(__SOFTFP__)"
            , String
"SOFTFP"
            , String
"#else"
            , String
"SOFT"
            , String
"#endif"
            ]
        case out of
          String
"HARD" -> ArmABI -> M ArmABI
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return ArmABI
HARD
          String
"SOFTFP" -> ArmABI -> M ArmABI
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return ArmABI
SOFTFP
          String
"SOFT" -> ArmABI -> M ArmABI
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return ArmABI
SOFT
          String
_ -> String -> M ArmABI
forall a. String -> M a
throwE (String -> M ArmABI) -> String -> M ArmABI
forall a b. (a -> b) -> a -> b
$ String
"unexpected output from test program: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
out

    extensions :: [(ArmISAExt, String)]
    extensions :: [(ArmISAExt, String)]
extensions =
        [ (ArmISAExt
NEON, String
"__ARM_NEON")
        , (ArmISAExt
VFPv2, String
"__VFP_FP__")
        , (ArmISAExt
VFPv2, String
"__ARM_VFPV2")
        , (ArmISAExt
VFPv3, String
"__ARM_VFPV3")
        ]

    checkExtension :: (ArmISAExt, String) -> M (Maybe ArmISAExt)
    checkExtension :: (ArmISAExt, String) -> M (Maybe ArmISAExt)
checkExtension (ArmISAExt
ext, String
macro) = do
        supported <- String -> M Bool -> M Bool
forall a. Show a => String -> M a -> M a
checking (String
"for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ArmISAExt -> String
forall a. Show a => a -> String
show ArmISAExt
ext String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" support") (M Bool -> M Bool) -> M Bool -> M Bool
forall a b. (a -> b) -> a -> b
$ String -> M Bool
testMacro String
macro
        return $
            if supported
              then Just ext
              else Nothing

    testMacro :: String -> M Bool
    testMacro :: String -> M Bool
testMacro String
macro = do
        out <- (String -> String) -> M String -> M String
forall a b. (a -> b) -> M a -> M b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
lastLine (M String -> M String) -> M String -> M String
forall a b. (a -> b) -> a -> b
$ Cc -> String -> M String
preprocess Cc
cc (String -> M String) -> String -> M String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [ String
"#if defined(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
macro String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
            , String
"True"
            , String
"#else"
            , String
"False"
            , String
"#endif"
            ]
        case out of
          String
"True" -> Bool -> M Bool
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          String
"False" -> Bool -> M Bool
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          String
_ -> String -> M Bool
forall a. String -> M a
throwE (String -> M Bool) -> String -> M Bool
forall a b. (a -> b) -> a -> b
$ String
"unexpected output from test program: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
out

lastLine :: String -> String
lastLine :: String -> String
lastLine String
"" = String
""
lastLine String
s  = [String] -> String
forall a. HasCallStack => [a] -> a
last ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s

-- | Raspbian unfortunately makes some extremely questionable packaging
-- decisions, configuring gcc to compile for ARMv6 despite the fact that the
-- Raspberry Pi 4 is ARMv8. As ARMv8 doesn't support all instructions supported
-- by ARMv6 this can break. Work around this by checking uname to verify that
-- we aren't running on armv7.
-- See #17856.
--
raspbianHack :: Arch -> M Arch
raspbianHack :: Arch -> M Arch
raspbianHack arch :: Arch
arch@(ArchARM ArmISA
ARMv6 [ArmISAExt]
_ ArmABI
abi) = do
    raspbian <- M Bool
isRaspbian
    armv7 <- isARMv7Host
    if raspbian && armv7
      then do logInfo "Found compiler which claims to target ARMv6 running in Raspbian on ARMv7."
              logInfo "Assuming we should actually target ARMv7 (see GHC #17856)"
              return $ ArchARM ARMv7 [VFPv2] abi
      else return arch
  where
    isRaspbian :: M Bool
isRaspbian = String -> M Bool -> M Bool
forall a. Show a => String -> M a -> M a
checking String
"whether this is Raspbian" (M Bool -> M Bool) -> M Bool -> M Bool
forall a b. (a -> b) -> a -> b
$ do
        issue <- String -> M String
readFile String
"/etc/issue" M String -> M String -> M String
forall a. M a -> M a -> M a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> M String
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
        return $ "Raspbian" `isInfixOf` issue

    isARMv7Host :: M Bool
isARMv7Host = String -> M Bool -> M Bool
forall a. Show a => String -> M a -> M a
checking String
"whether the host is ARMv7" (M Bool -> M Bool) -> M Bool -> M Bool
forall a b. (a -> b) -> a -> b
$ do
        uname <- IO String -> M String
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> M String) -> IO String -> M String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO String
readProcess String
"uname" [String
"-m"] String
""
        return $ "armv7" `isInfixOf` uname

raspbianHack Arch
arch = Arch -> M Arch
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Arch
arch

archTestProgram :: String
archTestProgram :: String
archTestProgram = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [ String
"#if defined(__ARM_ARCH)"
    , String
"__ARM_ARCH"
    ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [ String
"#elif defined(__ARM_ARCH_"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
archString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"__)\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
arch
    | String
arch <- [String]
armArchs
    ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [ String
"#else"
    , String
"#error \"unknown ARM platform\""
    , String
"#endif"
    ]

armArchs :: [String]
armArchs :: [String]
armArchs =
  [ String
"2"
  , String
"3", String
"3M"
  , String
"4", String
"4T"
  , String
"5", String
"5T", String
"5E", String
"5TE"
  , String
"6", String
"6J", String
"6T2", String
"6Z", String
"6ZK", String
"6K", String
"6KZ", String
"6M"
  , String
"7"
  ]