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
    ArmISA
isa <- M ArmISA
checkIsa
    ArmABI
abi <- M ArmABI
checkAbi
    [ArmISAExt]
exts <- [Maybe ArmISAExt] -> [ArmISAExt]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ArmISAExt] -> [ArmISAExt])
-> M [Maybe ArmISAExt] -> M [ArmISAExt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ArmISAExt, String) -> M (Maybe ArmISAExt))
-> [(ArmISAExt, String)] -> M [Maybe ArmISAExt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ArmISAExt, String) -> M (Maybe ArmISAExt)
checkExtension [(ArmISAExt, String)]
extensions
    let arch :: Arch
arch = ArmISA -> [ArmISAExt] -> ArmABI -> Arch
ArchARM ArmISA
isa [ArmISAExt]
exts ArmABI
abi
    Arch -> M Arch
raspbianHack Arch
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
        String
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 String
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
        String
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 String
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
        Bool
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
        Maybe ArmISAExt -> M (Maybe ArmISAExt)
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ArmISAExt -> M (Maybe ArmISAExt))
-> Maybe ArmISAExt -> M (Maybe ArmISAExt)
forall a b. (a -> b) -> a -> b
$
            if Bool
supported
              then ArmISAExt -> Maybe ArmISAExt
forall a. a -> Maybe a
Just ArmISAExt
ext
              else Maybe ArmISAExt
forall a. Maybe a
Nothing

    testMacro :: String -> M Bool
    testMacro :: String -> M Bool
testMacro String
macro = do
        String
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 String
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
    Bool
raspbian <- M Bool
isRaspbian
    Bool
armv7 <- M Bool
isARMv7Host
    if Bool
raspbian Bool -> Bool -> Bool
&& Bool
armv7
      then do String -> M ()
logInfo (String -> M ()) -> String -> M ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
"Found compiler which claims to target ARMv6 running in Raspbian on ARMv7."
                                , String
"Assuming we should actually target ARMv7 (see GHC #17856)"
                                ]
              Arch -> M Arch
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return (Arch -> M Arch) -> Arch -> M Arch
forall a b. (a -> b) -> a -> b
$ ArmISA -> [ArmISAExt] -> ArmABI -> Arch
ArchARM ArmISA
ARMv7 [ArmISAExt
VFPv2] ArmABI
abi
      else Arch -> M Arch
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Arch
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
        String
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
""
        Bool -> M Bool
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> M Bool) -> Bool -> M Bool
forall a b. (a -> b) -> a -> b
$ String
"Raspbian" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
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
        String
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
""
        Bool -> M Bool
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> M Bool) -> Bool -> M Bool
forall a b. (a -> b) -> a -> b
$ String
"armv7" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
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"
  ]