{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}

module GHC.Toolchain.Tools.Cc
    ( Cc(..)
    , _ccProgram
    , findBasicCc
    , findCc
      -- * Helpful utilities
    , preprocess
    , compileC
    , compileAsm
    , addPlatformDepCcFlags
    , checkC99Support
    ) where

import Control.Monad
import Data.List (isInfixOf) -- Wouldn't it be better to use bytestring?
import System.FilePath

import GHC.Platform.ArchOS

import GHC.Toolchain.Prelude
import GHC.Toolchain.Utils
import GHC.Toolchain.Program

newtype Cc = Cc { Cc -> Program
ccProgram :: Program
                }
    deriving (Int -> Cc -> ShowS
[Cc] -> ShowS
Cc -> String
(Int -> Cc -> ShowS)
-> (Cc -> String) -> ([Cc] -> ShowS) -> Show Cc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cc -> ShowS
showsPrec :: Int -> Cc -> ShowS
$cshow :: Cc -> String
show :: Cc -> String
$cshowList :: [Cc] -> ShowS
showList :: [Cc] -> ShowS
Show, ReadPrec [Cc]
ReadPrec Cc
Int -> ReadS Cc
ReadS [Cc]
(Int -> ReadS Cc)
-> ReadS [Cc] -> ReadPrec Cc -> ReadPrec [Cc] -> Read Cc
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Cc
readsPrec :: Int -> ReadS Cc
$creadList :: ReadS [Cc]
readList :: ReadS [Cc]
$creadPrec :: ReadPrec Cc
readPrec :: ReadPrec Cc
$creadListPrec :: ReadPrec [Cc]
readListPrec :: ReadPrec [Cc]
Read, Cc -> Cc -> Bool
(Cc -> Cc -> Bool) -> (Cc -> Cc -> Bool) -> Eq Cc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Cc -> Cc -> Bool
== :: Cc -> Cc -> Bool
$c/= :: Cc -> Cc -> Bool
/= :: Cc -> Cc -> Bool
Eq, Eq Cc
Eq Cc =>
(Cc -> Cc -> Ordering)
-> (Cc -> Cc -> Bool)
-> (Cc -> Cc -> Bool)
-> (Cc -> Cc -> Bool)
-> (Cc -> Cc -> Bool)
-> (Cc -> Cc -> Cc)
-> (Cc -> Cc -> Cc)
-> Ord Cc
Cc -> Cc -> Bool
Cc -> Cc -> Ordering
Cc -> Cc -> Cc
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 :: Cc -> Cc -> Ordering
compare :: Cc -> Cc -> Ordering
$c< :: Cc -> Cc -> Bool
< :: Cc -> Cc -> Bool
$c<= :: Cc -> Cc -> Bool
<= :: Cc -> Cc -> Bool
$c> :: Cc -> Cc -> Bool
> :: Cc -> Cc -> Bool
$c>= :: Cc -> Cc -> Bool
>= :: Cc -> Cc -> Bool
$cmax :: Cc -> Cc -> Cc
max :: Cc -> Cc -> Cc
$cmin :: Cc -> Cc -> Cc
min :: Cc -> Cc -> Cc
Ord)

_ccProgram :: Lens Cc Program
_ccProgram :: Lens Cc Program
_ccProgram = (Cc -> Program) -> (Program -> Cc -> Cc) -> Lens Cc Program
forall a b. (a -> b) -> (b -> a -> a) -> Lens a b
Lens Cc -> Program
ccProgram (\Program
x Cc
o -> Cc
o{ccProgram=x})

_ccFlags :: Lens Cc [String]
_ccFlags :: Lens Cc [String]
_ccFlags = Lens Cc Program
_ccProgram Lens Cc Program -> Lens Program [String] -> Lens Cc [String]
forall a b c. Lens a b -> Lens b c -> Lens a c
% Lens Program [String]
_prgFlags

-- We use this to find a minimally-functional compiler needed to call
-- parseTriple.
findBasicCc :: ProgOpt -> M Cc
findBasicCc :: ProgOpt -> M Cc
findBasicCc ProgOpt
progOpt = String -> M Cc -> M Cc
forall a. Show a => String -> M a -> M a
checking String
"for C compiler" (M Cc -> M Cc) -> M Cc -> M Cc
forall a b. (a -> b) -> a -> b
$ do
    -- TODO: We keep the candidate order we had in configure, but perhaps
    -- there's a more optimal one
    ccProgram <- String -> ProgOpt -> [String] -> M Program
findProgram String
"C compiler" ProgOpt
progOpt [String
"gcc", String
"clang", String
"cc"]
    return $ Cc{ccProgram}

findCc :: ArchOS
       -> String -- ^ The llvm target to use if Cc supports --target
       -> ProgOpt -> M Cc
findCc :: ArchOS -> String -> ProgOpt -> M Cc
findCc ArchOS
archOs String
llvmTarget ProgOpt
progOpt = do
    cc0 <- ProgOpt -> M Cc
findBasicCc ProgOpt
progOpt
    cc1 <- ignoreUnusedArgs cc0
    cc2 <- ccSupportsTarget archOs llvmTarget cc1
    checking "whether Cc works" $ checkCcWorks cc2
    cc3 <- oneOf "cc doesn't support C99" $ map checkC99Support
        [ cc2
        , cc2 & _ccFlags %++ "-std=gnu99"
        ]
    checkCcSupportsExtraViaCFlags cc3
    return cc3

checkCcWorks :: Cc -> M ()
checkCcWorks :: Cc -> M ()
checkCcWorks Cc
cc = (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 test_o :: String
test_o = String
dir String -> ShowS
</> String
"test.o"
    Cc -> String -> String -> M ()
compileC Cc
cc String
test_o (String -> M ()) -> String -> M ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
        [ String
"#include <stdio.h>"
        , String
"int main(int argc, char **argv) {"
        , String
"  printf(\"hello world!\");"
        , String
"  return 0;"
        , String
"}"
        ]

-- | GHC tends to produce command-lines with unused arguments that elicit
-- warnings from Clang. Clang offers the @-Qunused-arguments@ flag to silence
-- these. See #11684.
ignoreUnusedArgs :: Cc -> M Cc
ignoreUnusedArgs :: Cc -> M Cc
ignoreUnusedArgs Cc
cc
  | String
"-Qunused-arguments" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Lens Cc [String] -> Cc -> [String]
forall a b. Lens a b -> a -> b
view Lens Cc [String]
_ccFlags Cc
cc) = Cc -> M Cc
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Cc
cc
  | Bool
otherwise
  = String -> M Cc -> M Cc
forall a. Show a => String -> M a -> M a
checking String
"for -Qunused-arguments support" (M Cc -> M Cc) -> M Cc -> M Cc
forall a b. (a -> b) -> a -> b
$ do
      let cc' :: Cc
cc' = Cc
cc Cc -> (Cc -> Cc) -> Cc
forall a b. a -> (a -> b) -> b
& Lens Cc [String]
_ccFlags Lens Cc [String] -> String -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ String
"-Qunused-arguments"
      (Cc
cc' Cc -> M () -> M Cc
forall a b. a -> M b -> M a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Cc -> M ()
checkCcWorks Cc
cc') M Cc -> M Cc -> M Cc
forall a. M a -> M a -> M a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Cc -> M Cc
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Cc
cc

-- Does Cc support the --target=<triple> option? If so, we should pass it
-- whenever possible to avoid ambiguity and potential compile-time errors (e.g.
-- see #20162).
ccSupportsTarget :: ArchOS -> String -> Cc -> M Cc
ccSupportsTarget :: ArchOS -> String -> Cc -> M Cc
ccSupportsTarget ArchOS
archOs String
target Cc
cc =
    String -> M Cc -> M Cc
forall a. Show a => String -> M a -> M a
checking String
"whether Cc supports --target" (M Cc -> M Cc) -> M Cc -> M Cc
forall a b. (a -> b) -> a -> b
$
    ArchOS -> Lens Cc Program -> (Cc -> M ()) -> String -> Cc -> M Cc
forall compiler.
ArchOS
-> Lens compiler Program
-> (compiler -> M ())
-> String
-> compiler
-> M compiler
supportsTarget ArchOS
archOs Lens Cc Program
_ccProgram Cc -> M ()
checkCcWorks String
target Cc
cc

checkC99Support :: Cc -> M Cc
checkC99Support :: Cc -> M Cc
checkC99Support Cc
cc = String -> M Cc -> M Cc
forall a. Show a => String -> M a -> M a
checking String
"for C99 support" (M Cc -> M Cc) -> M Cc -> M Cc
forall a b. (a -> b) -> a -> b
$ (String -> M Cc) -> M Cc
forall a. (String -> M a) -> M a
withTempDir ((String -> M Cc) -> M Cc) -> (String -> M Cc) -> M Cc
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
    let test_o :: String
test_o = String
dir String -> ShowS
</> String
"test.o"
    Cc -> String -> String -> M ()
compileC Cc
cc String
test_o (String -> M ()) -> String -> M ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
        [ String
"#include <stdio.h>"
        , String
"#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L"
        , String
"# error \"Compiler does not advertise C99 conformance\""
        , String
"#endif"
        ]
    Cc -> M Cc
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Cc
cc

checkCcSupportsExtraViaCFlags :: Cc -> M ()
checkCcSupportsExtraViaCFlags :: Cc -> M ()
checkCcSupportsExtraViaCFlags Cc
cc = String -> M () -> M ()
forall a. Show a => String -> M a -> M a
checking String
"whether cc supports extra via-c flags" (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 test_o :: String
test_o = String
dir String -> ShowS
</> String
"test.o"
      test_c :: String
test_c = String
test_o String -> ShowS
-<.> String
"c"
  String -> String -> M ()
writeFile String
test_c String
"int main() { return 0; }"
  (code, out, err) <- Program -> [String] -> M (ExitCode, String, String)
readProgram (Cc -> Program
ccProgram Cc
cc)
                                  [ String
"-c"
                                  , String
"-fwrapv", String
"-fno-builtin"
                                  , String
"-Werror", String
"-x", String
"c"
                                  , String
"-o", String
test_o, String
test_c]
  when (not (isSuccess code)
        || "unrecognized" `isInfixOf` out
        || "unrecognized" `isInfixOf` err
        ) $
    throwE "Your C compiler must support the -fwrapv and -fno-builtin flags"

-- | Preprocess the given program.
preprocess
    :: Cc
    -> String   -- ^ program
    -> M String -- ^ preprocessed output
preprocess :: Cc -> String -> M String
preprocess Cc
cc String
prog = (String -> M String) -> M String
forall a. (String -> M a) -> M a
withTempDir ((String -> M String) -> M String)
-> (String -> M String) -> M String
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
    let out :: String
out = String
dir String -> ShowS
</> String
"test.c"
    String
-> [String] -> Lens Cc Program -> Cc -> String -> String -> M ()
forall compiler.
String
-> [String]
-> Lens compiler Program
-> compiler
-> String
-> String
-> M ()
compile String
"c" [String
"-E"] Lens Cc Program
_ccProgram Cc
cc String
out String
prog
    String -> M String
readFile String
out

-- | Compile a C source file to object code.
compileC
    :: Cc       -- ^ cc
    -> FilePath -- ^ output path
    -> String   -- ^ C source
    -> M ()
compileC :: Cc -> String -> String -> M ()
compileC = String
-> [String] -> Lens Cc Program -> Cc -> String -> String -> M ()
forall compiler.
String
-> [String]
-> Lens compiler Program
-> compiler
-> String
-> String
-> M ()
compile String
"c" [String
"-c"] Lens Cc Program
_ccProgram

-- | Compile an assembler source file to object code.
compileAsm
    :: Cc       -- ^ cc
    -> FilePath -- ^ output path
    -> String   -- ^ Assembler source
    -> M ()
compileAsm :: Cc -> String -> String -> M ()
compileAsm = String
-> [String] -> Lens Cc Program -> Cc -> String -> String -> M ()
forall compiler.
String
-> [String]
-> Lens compiler Program
-> compiler
-> String
-> String
-> M ()
compile String
"S" [String
"-c"] Lens Cc Program
_ccProgram

-- | Add various platform-dependent compiler flags needed by GHC. We can't do
-- this in `findCc` since we need a 'Cc` to determine the 'ArchOS'.
addPlatformDepCcFlags :: ArchOS -> Cc -> M Cc
addPlatformDepCcFlags :: ArchOS -> Cc -> M Cc
addPlatformDepCcFlags ArchOS
archOs Cc
cc0 = do
  let cc1 :: Cc
cc1 = ArchOS -> Cc -> Cc
addWorkaroundFor7799 ArchOS
archOs Cc
cc0
  -- As per FPTOOLS_SET_C_LD_FLAGS
  case ArchOS
archOs of
    ArchOS Arch
ArchX86 OS
OSFreeBSD ->
      Cc -> M Cc
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cc -> M Cc) -> Cc -> M Cc
forall a b. (a -> b) -> a -> b
$ Cc
cc1 Cc -> (Cc -> Cc) -> Cc
forall a b. a -> (a -> b) -> b
& Lens Cc [String]
_ccFlags Lens Cc [String] -> String -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ String
"-march=i686"
    ArchOS Arch
ArchX86_64 OS
OSSolaris2 ->
      -- Solaris is a multi-lib platform, providing both 32- and 64-bit
      -- user-land. It appears to default to 32-bit builds but we of course want to
      -- compile for 64-bits on x86-64.
      Cc -> M Cc
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cc -> M Cc) -> Cc -> M Cc
forall a b. (a -> b) -> a -> b
$ Cc
cc1 Cc -> (Cc -> Cc) -> Cc
forall a b. a -> (a -> b) -> b
& Lens Cc [String]
_ccFlags Lens Cc [String] -> String -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ String
"-m64"
    ArchOS Arch
ArchAlpha OS
_ ->
      -- For now, to suppress the gcc warning "call-clobbered
      -- register used for global register variable", we simply
      -- disable all warnings altogether using the -w flag. Oh well.
      Cc -> M Cc
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cc -> M Cc) -> Cc -> M Cc
forall a b. (a -> b) -> a -> b
$ Cc
cc1 Cc -> (Cc -> Cc) -> Cc
forall a b. a -> (a -> b) -> b
& Lens Cc [String] -> ([String] -> [String]) -> Cc -> Cc
forall a b. Lens a b -> (b -> b) -> a -> a
over Lens Cc [String]
_ccFlags ([String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String
"-w",String
"-mieee",String
"-D_REENTRANT"])
    -- ArchOS ArchHPPA? _ ->
    ArchOS ArchARM{} OS
OSFreeBSD ->
      -- On arm/freebsd, tell gcc to generate Arm
      -- instructions (ie not Thumb).
      Cc -> M Cc
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cc -> M Cc) -> Cc -> M Cc
forall a b. (a -> b) -> a -> b
$ Cc
cc1 Cc -> (Cc -> Cc) -> Cc
forall a b. a -> (a -> b) -> b
& Lens Cc [String]
_ccFlags Lens Cc [String] -> String -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ String
"-marm"
    ArchOS ArchARM{} OS
OSLinux ->
      -- On arm/linux and arm/android, tell gcc to generate Arm
      -- instructions (ie not Thumb).
      Cc -> M Cc
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cc -> M Cc) -> Cc -> M Cc
forall a b. (a -> b) -> a -> b
$ Cc
cc1 Cc -> (Cc -> Cc) -> Cc
forall a b. a -> (a -> b) -> b
& Lens Cc [String]
_ccFlags Lens Cc [String] -> String -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ String
"-marm"
    ArchOS Arch
ArchPPC OS
OSAIX ->
      -- We need `-D_THREAD_SAFE` to unlock the thread-local `errno`.
      Cc -> M Cc
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cc -> M Cc) -> Cc -> M Cc
forall a b. (a -> b) -> a -> b
$ Cc
cc1 Cc -> (Cc -> Cc) -> Cc
forall a b. a -> (a -> b) -> b
& Lens Cc [String]
_ccFlags Lens Cc [String] -> String -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ String
"-D_THREAD_SAFE"
    ArchOS Arch
ArchLoongArch64 OS
OSLinux ->
      -- On LoongArch64, we need `-mcmodel=medium` to tell gcc to generate big
      -- enough jump instruction.
      Cc -> M Cc
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cc -> M Cc) -> Cc -> M Cc
forall a b. (a -> b) -> a -> b
$ Cc
cc1 Cc -> (Cc -> Cc) -> Cc
forall a b. a -> (a -> b) -> b
& Lens Cc [String]
_ccFlags Lens Cc [String] -> String -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ String
"-mcmodel=medium"
    ArchOS
_ ->
      Cc -> M Cc
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Cc
cc1


-- | Workaround for #7799
addWorkaroundFor7799 :: ArchOS -> Cc -> Cc
addWorkaroundFor7799 :: ArchOS -> Cc -> Cc
addWorkaroundFor7799 ArchOS
archOs Cc
cc
  | Arch
ArchX86 <- ArchOS -> Arch
archOS_arch ArchOS
archOs = Cc
cc Cc -> (Cc -> Cc) -> Cc
forall a b. a -> (a -> b) -> b
& Lens Cc [String]
_ccFlags Lens Cc [String] -> String -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ String
"-U__i686"
  | Bool
otherwise = Cc
cc