    {-# 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
    OSMinGW32 ->
          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 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
    _ ->
          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