    {-# LANGUAGE CPP #-}
    {-# LANGUAGE LambdaCase #-}

    #include <ghcplatform.h>

    module GHC.SysTools.Cpp
      ( doCpp
      , CppOpts(..)
      , getGhcVersionPathName
      , applyCDefs
      , offsetIncludePaths
      )
    where

    import GHC.Prelude
    import GHC.Driver.Session
    import GHC.Driver.Backend
    import GHC.CmmToLlvm.Version
    import GHC.Platform
    import GHC.Platform.ArchOS

    import GHC.SysTools

    import GHC.Unit.Env
    import GHC.Unit.Info
    import GHC.Unit.State
    import GHC.Unit.Types

    import GHC.Utils.Logger
    import GHC.Utils.TmpFs
    import GHC.Utils.Panic

    import Data.Version
    import Data.List (intercalate)
    import Data.Maybe

    import Control.Monad

    import System.Directory
    import System.FilePath

    data CppOpts = CppOpts
      { CppOpts -> Bool
    useHsCpp       :: !Bool
      -- ^ Use the Haskell C preprocessor, otherwise use the C preprocessor.
      -- See the Note [Preprocessing invocations]
      , CppOpts -> Bool
    cppLinePragmas :: !Bool
      -- ^ Enable generation of LINE pragmas
      }

    {-
    Note [Preprocessing invocations]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We must consider two distinct preprocessors when preprocessing Haskell.
    These are:

    (1) The Haskell C preprocessor (HsCpp), which preprocesses Haskell files that make use
      of the CPP language extension

    (2) The C preprocessor (Cpp), which is used to preprocess C and Cmm files

    These preprocessors are indeed different. Despite often sharing the same
    underlying program (the C compiler), the set of flags passed determines the
    behaviour of the preprocessor, and Cpp and HsCpp behave differently.
    Specifically, we rely on "traditional" (pre-standard) preprocessing semantics
    (which most compilers expose via the `-traditional` flag) when preprocessing
    Haskell source. This avoids, e.g., the preprocessor removing C-style comments.
    -}

    -- | Run either the Haskell preprocessor or the C preprocessor, as per the
    -- 'CppOpts' passed. See Note [Preprocessing invocations].
    --
    -- UnitEnv is needed to compute MIN_VERSION macros
    doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> CppOpts -> FilePath -> FilePath -> IO ()
    doCpp :: Logger
    -> TmpFs
    -> DynFlags
    -> UnitEnv
    -> CppOpts
    -> String
    -> String
    -> IO ()
    doCpp Logger
    logger TmpFs
    tmpfs DynFlags
    dflags UnitEnv
    unit_env CppOpts
    opts String
    input_fn String
    output_fn = do
        let hscpp_opts :: [String]
    hscpp_opts = DynFlags -> [String]
    picPOpts DynFlags
    dflags
        let cmdline_include_paths :: IncludeSpecs
    cmdline_include_paths = DynFlags -> IncludeSpecs -> IncludeSpecs
    offsetIncludePaths DynFlags
    dflags (DynFlags -> IncludeSpecs
    includePaths DynFlags
    dflags)
        let unit_state :: UnitState
    unit_state = HasDebugCallStack => UnitEnv -> UnitState
    UnitEnv -> UnitState
    ue_units UnitEnv
    unit_env
        pkg_include_dirs <- MaybeErr UnitErr [String] -> IO [String]
    forall a. MaybeErr UnitErr a -> IO a
    mayThrowUnitErr
                            ([UnitInfo] -> [String]
    collectIncludeDirs ([UnitInfo] -> [String])
    -> MaybeErr UnitErr [UnitInfo] -> MaybeErr UnitErr [String]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnitEnv -> MaybeErr UnitErr [UnitInfo]
    preloadUnitsInfo UnitEnv
    unit_env)
        -- MP: This is not quite right, the headers which are supposed to be installed in
        -- the package might not be the same as the provided include paths, but it's a close
        -- enough approximation for things to work. A proper solution would be to have to declare which paths should
        -- be propagated to dependent packages.
        let home_pkg_deps =
             [HomeUnitEnv -> DynFlags
    homeUnitEnv_dflags (HomeUnitEnv -> DynFlags)
    -> (UnitEnv -> HomeUnitEnv) -> UnitEnv -> DynFlags
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv
    UnitId -> UnitEnv -> HomeUnitEnv
    ue_findHomeUnitEnv UnitId
    uid (UnitEnv -> DynFlags) -> UnitEnv -> DynFlags
    forall a b. (a -> b) -> a -> b
    $ UnitEnv
    unit_env | UnitId
    uid <- UnitId -> UnitEnv -> [UnitId]
    ue_transitiveHomeDeps (UnitEnv -> UnitId
    ue_currentUnit UnitEnv
    unit_env) UnitEnv
    unit_env]
            dep_pkg_extra_inputs = [DynFlags -> IncludeSpecs -> IncludeSpecs
    offsetIncludePaths DynFlags
    fs (DynFlags -> IncludeSpecs
    includePaths DynFlags
    fs) | DynFlags
    fs <- [DynFlags]
    home_pkg_deps]

        let include_paths_global = (String -> [String] -> [String])
    -> [String] -> [String] -> [String]
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\ String
    x [String]
    xs -> (String
    "-I" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    x) String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : [String]
    xs) []
              (IncludeSpecs -> [String]
    includePathsGlobal IncludeSpecs
    cmdline_include_paths [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String]
    pkg_include_dirs
                                                        [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ (IncludeSpecs -> [String]) -> [IncludeSpecs] -> [String]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap IncludeSpecs -> [String]
    includePathsGlobal [IncludeSpecs]
    dep_pkg_extra_inputs)
        let include_paths_quote = (String -> [String] -> [String])
    -> [String] -> [String] -> [String]
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\ String
    x [String]
    xs -> (String
    "-iquote" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    x) String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : [String]
    xs) []
              (IncludeSpecs -> [String]
    includePathsQuote IncludeSpecs
    cmdline_include_paths [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++
               IncludeSpecs -> [String]
    includePathsQuoteImplicit IncludeSpecs
    cmdline_include_paths)
        let include_paths = [String]
    include_paths_quote [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String]
    include_paths_global

        let verbFlags = DynFlags -> [String]
    getVerbFlags DynFlags
    dflags

        let cpp_prog [Option]
    args
              | CppOpts -> Bool
    useHsCpp CppOpts
    opts = Logger -> DynFlags -> [Option] -> IO ()
    GHC.SysTools.runHsCpp Logger
    logger DynFlags
    dflags [Option]
    args
              | Bool
    otherwise     = Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
    GHC.SysTools.runCpp Logger
    logger TmpFs
    tmpfs DynFlags
    dflags [Option]
    args

        let platform   = DynFlags -> Platform
    targetPlatform DynFlags
    dflags
            targetArch = Arch -> String
    stringEncodeArch (Arch -> String) -> Arch -> String
    forall a b. (a -> b) -> a -> b
    $ Platform -> Arch
    platformArch Platform
    platform
            targetOS = OS -> String
    stringEncodeOS (OS -> String) -> OS -> String
    forall a b. (a -> b) -> a -> b
    $ Platform -> OS
    platformOS Platform
    platform
            isWindows = Platform -> OS
    platformOS Platform
    platform OS -> OS -> Bool
    forall a. Eq a => a -> a -> Bool
    == OS
    OSMinGW32
        let target_defs =
              [ String
    "-D" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    HOST_OS     String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "_BUILD_OS",
                String
    "-D" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ HOST_ARCH   ++ "_BUILD_ARCH",
                String
    "-D" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    targetOS    String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "_HOST_OS",
                String
    "-D" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    targetArch  String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "_HOST_ARCH" ]
            -- remember, in code we *compile*, the HOST is the same our TARGET,
            -- and BUILD is the same as our HOST.

        let io_manager_defs =
              [ String
    "-D__IO_MANAGER_WINIO__=1" | Bool
    isWindows ] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++
              [ String
    "-D__IO_MANAGER_MIO__=1"               ]

        let sse_defs =
              [ String
    "-D__SSE__"      | Platform -> Bool
    isSseEnabled      Platform
    platform ] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++
              [ String
    "-D__SSE2__"     | Platform -> Bool
    isSse2Enabled     Platform
    platform ] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++
              [ String
    "-D__SSE4_2__"   | DynFlags -> Bool
    isSse4_2Enabled   DynFlags
    dflags ]

        let fma_def =
             [ String
    "-D__FMA__"       | DynFlags -> Bool
    isFmaEnabled DynFlags
    dflags ]

        let avx_defs =
              [ String
    "-D__AVX__"      | DynFlags -> Bool
    isAvxEnabled      DynFlags
    dflags ] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++
              [ String
    "-D__AVX2__"     | DynFlags -> Bool
    isAvx2Enabled     DynFlags
    dflags ] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++
              [ String
    "-D__AVX512CD__" | DynFlags -> Bool
    isAvx512cdEnabled DynFlags
    dflags ] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++
              [ String
    "-D__AVX512ER__" | DynFlags -> Bool
    isAvx512erEnabled DynFlags
    dflags ] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++
              [ String
    "-D__AVX512F__"  | DynFlags -> Bool
    isAvx512fEnabled  DynFlags
    dflags ] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++
              [ String
    "-D__AVX512PF__" | DynFlags -> Bool
    isAvx512pfEnabled DynFlags
    dflags ]

        backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags

        let th_defs = [ String
    "-D__GLASGOW_HASKELL_TH__" ]
        -- Default CPP defines in Haskell source
        ghcVersionH <- getGhcVersionPathName dflags unit_env
        let hsSourceCppOpts = [ String
    "-include", String
    ghcVersionH ]

        -- MIN_VERSION macros
        let uids = UnitState -> [(Unit, Maybe PackageArg)]
    explicitUnits UnitState
    unit_state
            pkgs = ((Unit, Maybe PackageArg) -> Maybe UnitInfo)
    -> [(Unit, Maybe PackageArg)] -> [UnitInfo]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (UnitState -> Unit -> Maybe UnitInfo
    lookupUnit UnitState
    unit_state (Unit -> Maybe UnitInfo)
    -> ((Unit, Maybe PackageArg) -> Unit)
    -> (Unit, Maybe PackageArg)
    -> Maybe UnitInfo
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Unit, Maybe PackageArg) -> Unit
    forall a b. (a, b) -> a
    fst) [(Unit, Maybe PackageArg)]
    uids
        mb_macro_include <-
            if not (null pkgs) && gopt Opt_VersionMacros dflags
                then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"
                        writeFile macro_stub (generatePackageVersionMacros pkgs)
                        -- Include version macros for every *exposed* package.
                        -- Without -hide-all-packages and with a package database
                        -- size of 1000 packages, it takes cpp an estimated 2
                        -- milliseconds to process this file. See #10970
                        -- comment 8.
                        return [GHC.SysTools.FileOption "-include" macro_stub]
                else return []

        let line_pragmas
              | CppOpts -> Bool
    cppLinePragmas CppOpts
    opts = [] -- on by default
              | Bool
    otherwise           = [String -> Option
    GHC.SysTools.Option String
    "-P"] -- disable LINE markers

        cpp_prog       (   map GHC.SysTools.Option verbFlags
                        ++ map GHC.SysTools.Option include_paths
                        ++ map GHC.SysTools.Option hsSourceCppOpts
                        ++ map GHC.SysTools.Option target_defs
                        ++ map GHC.SysTools.Option backend_defs
                        ++ map GHC.SysTools.Option th_defs
                        ++ map GHC.SysTools.Option hscpp_opts
                        ++ map GHC.SysTools.Option sse_defs
                        ++ map GHC.SysTools.Option fma_def
                        ++ map GHC.SysTools.Option avx_defs
                        ++ map GHC.SysTools.Option io_manager_defs
                        ++ mb_macro_include
                        ++ line_pragmas
            -- Set the language mode to assembler-with-cpp when preprocessing. This
            -- alleviates some of the C99 macro rules relating to whitespace and the hash
            -- operator, which we tend to abuse. Clang in particular is not very happy
            -- about this.
                        ++ [ GHC.SysTools.Option     "-x"
                           , GHC.SysTools.Option     "assembler-with-cpp"
                           , GHC.SysTools.Option     input_fn
            -- We hackily use Option instead of FileOption here, so that the file
            -- name is not back-slashed on Windows.  cpp is capable of
            -- dealing with / in filenames, so it works fine.  Furthermore
            -- if we put in backslashes, cpp outputs #line directives
            -- with *double* backslashes.   And that in turn means that
            -- our error messages get double backslashes in them.
            -- In due course we should arrange that the lexer deals
            -- with these \\ escapes properly.
                           , GHC.SysTools.Option     "-o"
                           , GHC.SysTools.FileOption "" output_fn
                           ])

    -- ---------------------------------------------------------------------------
    -- Macros (cribbed from Cabal)

    generatePackageVersionMacros :: [UnitInfo] -> String
    generatePackageVersionMacros :: [UnitInfo] -> String
    generatePackageVersionMacros [UnitInfo]
    pkgs = [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
      -- Do not add any C-style comments. See #3389.
      [ String -> String -> Version -> String
    generateMacros String
    "" String
    pkgname Version
    version
      | UnitInfo
    pkg <- [UnitInfo]
    pkgs
      , let version :: Version
    version = UnitInfo -> Version
    forall srcpkgid srcpkgname uid modulename mod.
    GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Version
    unitPackageVersion UnitInfo
    pkg
            pkgname :: String
    pkgname = (Char -> Char) -> String -> String
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    fixchar (UnitInfo -> String
    forall u. GenUnitInfo u -> String
    unitPackageNameString UnitInfo
    pkg)
      ]

    fixchar :: Char -> Char
    fixchar :: Char -> Char
    fixchar Char
    '-' = Char
    '_'
    fixchar Char
    c   = Char
    c

    generateMacros :: String -> String -> Version -> String
    generateMacros :: String -> String -> Version -> String
    generateMacros String
    prefix String
    name Version
    version =
      [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
      [String
    "#define ", String
    prefix, String
    "VERSION_",String
    name,String
    " ",String -> String
    forall a. Show a => a -> String
    show (Version -> String
    showVersion Version
    version),String
    "\n"
      ,String
    "#define MIN_", String
    prefix, String
    "VERSION_",String
    name,String
    "(major1,major2,minor) (\\\n"
      ,String
    "  (major1) <  ",String
    major1,String
    " || \\\n"
      ,String
    "  (major1) == ",String
    major1,String
    " && (major2) <  ",String
    major2,String
    " || \\\n"
      ,String
    "  (major1) == ",String
    major1,String
    " && (major2) == ",String
    major2,String
    " && (minor) <= ",String
    minor,String
    ")"
      ,String
    "\n\n"
      ]
      where
        take3 :: [c] -> (c, c, c)
    take3 = \case
          (c
    a:c
    b:c
    c:[c]
    _) -> (c
    a,c
    b,c
    c)
          [c]
    _         -> String -> (c, c, c)
    forall a. HasCallStack => String -> a
    error String
    "take3"
        (String
    major1,String
    major2,String
    minor) = [String] -> (String, String, String)
    forall {c}. [c] -> (c, c, c)
    take3 ([String] -> (String, String, String))
    -> [String] -> (String, String, String)
    forall a b. (a -> b) -> a -> b
    $ (Int -> String) -> [Int] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> String
    forall a. Show a => a -> String
    show (Version -> [Int]
    versionBranch Version
    version) [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ String -> [String]
    forall a. a -> [a]
    repeat String
    "0"

    -- | Find out path to @ghcversion.h@ file
    getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
    getGhcVersionPathName :: DynFlags -> UnitEnv -> IO String
    getGhcVersionPathName DynFlags
    dflags UnitEnv
    unit_env = do
      candidates <- case DynFlags -> Maybe String
    ghcVersionFile DynFlags
    dflags of
        Just String
    path -> [String] -> IO [String]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [String
    path]
        Maybe String
    Nothing -> do
            ps <- MaybeErr UnitErr [UnitInfo] -> IO [UnitInfo]
    forall a. MaybeErr UnitErr a -> IO a
    mayThrowUnitErr (UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]
    preloadUnitsInfo' UnitEnv
    unit_env [UnitId
    rtsUnitId])
            return ((</> "ghcversion.h") <$> collectIncludeDirs ps)

      found <- filterM doesFileExist candidates
      case found of
          []    -> GhcException -> IO String
    forall a. GhcException -> IO a
    throwGhcExceptionIO (String -> GhcException
    InstallationError
                                        (String
    "ghcversion.h missing; tried: "
                                          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    ", " [String]
    candidates))
          (String
    x:[String]
    _) -> String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    x

    applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String]
    applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String]
    applyCDefs DefunctionalizedCDefs
    NoCDefs Logger
    _ DynFlags
    _ = [String] -> IO [String]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
    applyCDefs DefunctionalizedCDefs
    LlvmCDefs Logger
    logger DynFlags
    dflags = do
        llvmVer <- Logger -> DynFlags -> IO (Maybe LlvmVersion)
    figureLlvmVersion Logger
    logger DynFlags
    dflags
        return $ case fmap llvmVersionList llvmVer of
                   Just [Int
    m] -> [ String
    "-D__GLASGOW_HASKELL_LLVM__=" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Int, Int) -> String
    format (Int
    m,Int
    0) ]
                   Just (Int
    m:Int
    n:[Int]
    _) -> [ String
    "-D__GLASGOW_HASKELL_LLVM__=" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Int, Int) -> String
    format (Int
    m,Int
    n) ]
                   Maybe [Int]
    _ -> []
      where
        format :: (Int, Int) -> String
    format (Int
    major, Int
    minor)
          | Int
    minor Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    100 = String -> String
    forall a. HasCallStack => String -> a
    error String
    "backendCDefs: Unsupported minor version"
          | Bool
    otherwise = Int -> String
    forall a. Show a => a -> String
    show (Int
    100 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    major Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    minor :: Int) -- Contract is Int

    -- Note [Filepaths and Multiple Home Units]
    offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs
    offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs
    offsetIncludePaths DynFlags
    dflags (IncludeSpecs [String]
    incs [String]
    quotes [String]
    impl) =
         let go :: [String] -> [String]
    go = (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (DynFlags -> String -> String
    augmentByWorkingDirectory DynFlags
    dflags)
         in [String] -> [String] -> [String] -> IncludeSpecs
    IncludeSpecs ([String] -> [String]
    go [String]
    incs) ([String] -> [String]
    go [String]
    quotes) ([String] -> [String]
    go [String]
    impl)