{-# 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 -> [Char]
(Int -> Cc -> ShowS)
-> (Cc -> [Char]) -> ([Cc] -> ShowS) -> Show Cc
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cc -> ShowS
showsPrec :: Int -> Cc -> ShowS
$cshow :: Cc -> [Char]
show :: Cc -> [Char]
$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 [[Char]]
_ccFlags = Lens Cc Program
_ccProgram Lens Cc Program -> Lens Program [[Char]] -> Lens Cc [[Char]]
forall a b c. Lens a b -> Lens b c -> Lens a c
% Lens Program [[Char]]
_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 = [Char] -> M Cc -> M Cc
forall a. Show a => [Char] -> M a -> M a
checking [Char]
"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 <- [Char] -> ProgOpt -> [[Char]] -> M Program
findProgram [Char]
"C compiler" ProgOpt
progOpt [[Char]
"gcc", [Char]
"clang", [Char]
"cc"]
    return $ Cc{ccProgram}

findCc :: ArchOS
       -> String -- ^ The llvm target to use if Cc supports --target
       -> ProgOpt -> M Cc
findCc :: ArchOS -> [Char] -> ProgOpt -> M Cc
findCc ArchOS
archOs [Char]
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 = ([Char] -> M ()) -> M ()
forall a. ([Char] -> M a) -> M a
withTempDir (([Char] -> M ()) -> M ()) -> ([Char] -> M ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
    let test_o :: [Char]
test_o = [Char]
dir [Char] -> ShowS
</> [Char]
"test.o"
    Cc -> [Char] -> [Char] -> M ()
compileC Cc
cc [Char]
test_o ([Char] -> M ()) -> [Char] -> M ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
        [ [Char]
"#include <stdio.h>"
        , [Char]
"int main(int argc, char **argv) {"
        , [Char]
"  printf(\"hello world!\");"
        , [Char]
"  return 0;"
        , [Char]
"}"
        ]

-- | 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
  | [Char]
"-Qunused-arguments" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Lens Cc [[Char]] -> Cc -> [[Char]]
forall a b. Lens a b -> a -> b
view Lens Cc [[Char]]
_ccFlags Cc
cc) = Cc -> M Cc
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Cc
cc
  | Bool
otherwise
  = [Char] -> M Cc -> M Cc
forall a. Show a => [Char] -> M a -> M a
checking [Char]
"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 [[Char]]
_ccFlags Lens Cc [[Char]] -> [Char] -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ [Char]
"-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 -> [Char] -> Cc -> M Cc
ccSupportsTarget ArchOS
archOs [Char]
target Cc
cc =
    [Char] -> M Cc -> M Cc
forall a. Show a => [Char] -> M a -> M a
checking [Char]
"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 ()) -> [Char] -> Cc -> M Cc
forall compiler.
ArchOS
-> Lens compiler Program
-> (compiler -> M ())
-> [Char]
-> compiler
-> M compiler
supportsTarget ArchOS
archOs Lens Cc Program
_ccProgram Cc -> M ()
checkCcWorks [Char]
target Cc
cc

checkC99Support :: Cc -> M Cc
checkC99Support :: Cc -> M Cc
checkC99Support Cc
cc = [Char] -> M Cc -> M Cc
forall a. Show a => [Char] -> M a -> M a
checking [Char]
"for C99 support" (M Cc -> M Cc) -> M Cc -> M Cc
forall a b. (a -> b) -> a -> b
$ ([Char] -> M Cc) -> M Cc
forall a. ([Char] -> M a) -> M a
withTempDir (([Char] -> M Cc) -> M Cc) -> ([Char] -> M Cc) -> M Cc
forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
    let test_o :: [Char]
test_o = [Char]
dir [Char] -> ShowS
</> [Char]
"test.o"
    Cc -> [Char] -> [Char] -> M ()
compileC Cc
cc [Char]
test_o ([Char] -> M ()) -> [Char] -> M ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
        [ [Char]
"#include <stdio.h>"
        , [Char]
"#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L"
        , [Char]
"# error \"Compiler does not advertise C99 conformance\""
        , [Char]
"#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 = [Char] -> M () -> M ()
forall a. Show a => [Char] -> M a -> M a
checking [Char]
"whether cc supports extra via-c flags" (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ ([Char] -> M ()) -> M ()
forall a. ([Char] -> M a) -> M a
withTempDir (([Char] -> M ()) -> M ()) -> ([Char] -> M ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
  let test_o :: [Char]
test_o = [Char]
dir [Char] -> ShowS
</> [Char]
"test.o"
      test_c :: [Char]
test_c = [Char]
test_o [Char] -> ShowS
-<.> [Char]
"c"
  [Char] -> [Char] -> M ()
writeFile [Char]
test_c [Char]
"int main() { return 0; }"
  (code, out, err) <- Program -> [[Char]] -> M (ExitCode, [Char], [Char])
readProgram (Cc -> Program
ccProgram Cc
cc)
                                  [ [Char]
"-c"
                                  , [Char]
"-fwrapv", [Char]
"-fno-builtin"
                                  , [Char]
"-Werror", [Char]
"-x", [Char]
"c"
                                  , [Char]
"-o", [Char]
test_o, [Char]
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 -> [Char] -> M [Char]
preprocess Cc
cc [Char]
prog = ([Char] -> M [Char]) -> M [Char]
forall a. ([Char] -> M a) -> M a
withTempDir (([Char] -> M [Char]) -> M [Char])
-> ([Char] -> M [Char]) -> M [Char]
forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
    let out :: [Char]
out = [Char]
dir [Char] -> ShowS
</> [Char]
"test.c"
    [Char]
-> [[Char]] -> Lens Cc Program -> Cc -> [Char] -> [Char] -> M ()
forall compiler.
[Char]
-> [[Char]]
-> Lens compiler Program
-> compiler
-> [Char]
-> [Char]
-> M ()
compile [Char]
"c" [[Char]
"-E"] Lens Cc Program
_ccProgram Cc
cc [Char]
out [Char]
prog
    [Char] -> M [Char]
readFile [Char]
out

-- | Compile a C source file to object code.
compileC
    :: Cc       -- ^ cc
    -> FilePath -- ^ output path
    -> String   -- ^ C source
    -> M ()
compileC :: Cc -> [Char] -> [Char] -> M ()
compileC = [Char]
-> [[Char]] -> Lens Cc Program -> Cc -> [Char] -> [Char] -> M ()
forall compiler.
[Char]
-> [[Char]]
-> Lens compiler Program
-> compiler
-> [Char]
-> [Char]
-> M ()
compile [Char]
"c" [[Char]
"-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 -> [Char] -> [Char] -> M ()
compileAsm = [Char]
-> [[Char]] -> Lens Cc Program -> Cc -> [Char] -> [Char] -> M ()
forall compiler.
[Char]
-> [[Char]]
-> Lens compiler Program
-> compiler
-> [Char]
-> [Char]
-> M ()
compile [Char]
"S" [[Char]
"-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 [[Char]]
_ccFlags Lens Cc [[Char]] -> [Char] -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ [Char]
"-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 [[Char]]
_ccFlags Lens Cc [[Char]] -> [Char] -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ [Char]
"-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 [[Char]] -> ([[Char]] -> [[Char]]) -> Cc -> Cc
forall a b. Lens a b -> (b -> b) -> a -> a
over Lens Cc [[Char]]
_ccFlags ([[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++[[Char]
"-w",[Char]
"-mieee",[Char]
"-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 [[Char]]
_ccFlags Lens Cc [[Char]] -> [Char] -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ [Char]
"-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 [[Char]]
_ccFlags Lens Cc [[Char]] -> [Char] -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ [Char]
"-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 [[Char]]
_ccFlags Lens Cc [[Char]] -> [Char] -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ [Char]
"-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 [[Char]]
_ccFlags Lens Cc [[Char]] -> [Char] -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ [Char]
"-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 [[Char]]
_ccFlags Lens Cc [[Char]] -> [Char] -> Cc -> Cc
forall a b. Lens a [b] -> b -> a -> a
%++ [Char]
"-U__i686"
  | Bool
otherwise = Cc
cc