-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

-- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019
-- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944.
-- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed.

{- HLINT ignore -} -- since copied from upstream

{-# LANGUAGE CPP                      #-}
{-# LANGUAGE MultiWayIf               #-}
{-# LANGUAGE NamedFieldPuns           #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
#include "ghc-api-version.h"

-----------------------------------------------------------------------------
--
-- GHC Driver
--
-- (c) The University of Glasgow 2005
--
-----------------------------------------------------------------------------

module Development.IDE.GHC.CPP(doCpp, addOptP)
where

import           Development.IDE.GHC.Compat
import           FileCleanup
import           Module
import           Packages
import           Panic
import           SysTools
#if MIN_GHC_API_VERSION(8,8,2)
import           LlvmCodeGen                (llvmVersionList)
#elif MIN_GHC_API_VERSION(8,8,0)
import           LlvmCodeGen                (LlvmVersion (..))
#endif
#if MIN_GHC_API_VERSION (8,10,0)
import           Fingerprint
import           ToolSettings
#endif

import           Control.Monad
import           Data.List                  (intercalate)
import           Data.Maybe
import           Data.Version
import           System.Directory
import           System.FilePath
import           System.Info



doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp DynFlags
dflags Bool
raw FilePath
input_fn FilePath
output_fn = do
    let hscpp_opts :: [FilePath]
hscpp_opts = DynFlags -> [FilePath]
picPOpts DynFlags
dflags
    let cmdline_include_paths :: IncludeSpecs
cmdline_include_paths = DynFlags -> IncludeSpecs
includePaths DynFlags
dflags

    [FilePath]
pkg_include_dirs <- DynFlags -> [PreloadUnitId] -> IO [FilePath]
getPackageIncludePath DynFlags
dflags []
    let include_paths_global :: [FilePath]
include_paths_global = (FilePath -> [FilePath] -> [FilePath])
-> [FilePath] -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ FilePath
x [FilePath]
xs -> (FilePath
"-I" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
xs) []
          (IncludeSpecs -> [FilePath]
includePathsGlobal IncludeSpecs
cmdline_include_paths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_include_dirs)
    let include_paths_quote :: [FilePath]
include_paths_quote = (FilePath -> [FilePath] -> [FilePath])
-> [FilePath] -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ FilePath
x [FilePath]
xs -> (FilePath
"-iquote" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
xs) []
          (IncludeSpecs -> [FilePath]
includePathsQuote IncludeSpecs
cmdline_include_paths)
    let include_paths :: [FilePath]
include_paths = [FilePath]
include_paths_quote [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
include_paths_global

    let verbFlags :: [FilePath]
verbFlags = DynFlags -> [FilePath]
getVerbFlags DynFlags
dflags

    let cpp_prog :: [Option] -> IO ()
cpp_prog [Option]
args | Bool
raw       = DynFlags -> [Option] -> IO ()
SysTools.runCpp DynFlags
dflags [Option]
args
#if MIN_GHC_API_VERSION(8,10,0)
                      | Bool
otherwise = Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()
SysTools.runCc Maybe ForeignSrcLang
forall a. Maybe a
Nothing
#else
                      | otherwise = SysTools.runCc
#endif
                                          DynFlags
dflags (FilePath -> Option
SysTools.Option FilePath
"-E" Option -> [Option] -> [Option]
forall a. a -> [a] -> [a]
: [Option]
args)

    let target_defs :: [FilePath]
target_defs =
          -- NEIL: Patched to use System.Info instead of constants from CPP
          [ FilePath
"-D" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
os     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_BUILD_OS",
            FilePath
"-D" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
arch   FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_BUILD_ARCH",
            FilePath
"-D" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
os     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_HOST_OS",
            FilePath
"-D" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
arch   FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_HOST_ARCH" ]
        -- remember, in code we *compile*, the HOST is the same our TARGET,
        -- and BUILD is the same as our HOST.

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

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

    [FilePath]
backend_defs <- DynFlags -> IO [FilePath]
getBackendDefs DynFlags
dflags

    let th_defs :: [FilePath]
th_defs = [ FilePath
"-D__GLASGOW_HASKELL_TH__" ]
    -- Default CPP defines in Haskell source
    FilePath
ghcVersionH <- DynFlags -> IO FilePath
getGhcVersionPathName DynFlags
dflags
    let hsSourceCppOpts :: [FilePath]
hsSourceCppOpts = [ FilePath
"-include", FilePath
ghcVersionH ]

    -- MIN_VERSION macros
    let uids :: [UnitId]
uids = PackageState -> [UnitId]
explicitPackages (DynFlags -> PackageState
pkgState DynFlags
dflags)
        pkgs :: [PackageConfig]
pkgs = [Maybe PackageConfig] -> [PackageConfig]
forall a. [Maybe a] -> [a]
catMaybes ((UnitId -> Maybe PackageConfig)
-> [UnitId] -> [Maybe PackageConfig]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage DynFlags
dflags) [UnitId]
uids)
    [Option]
mb_macro_include <-
        if Bool -> Bool
not ([PackageConfig] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageConfig]
pkgs) Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_VersionMacros DynFlags
dflags
            then do FilePath
macro_stub <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule FilePath
"h"
                    FilePath -> FilePath -> IO ()
writeFile FilePath
macro_stub ([PackageConfig] -> FilePath
generatePackageVersionMacros [PackageConfig]
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 [FilePath -> FilePath -> Option
SysTools.FileOption FilePath
"-include" FilePath
macro_stub]
            else [Option] -> IO [Option]
forall (m :: * -> *) a. Monad m => a -> m a
return []

    [Option] -> IO ()
cpp_prog       (   (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
verbFlags
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
include_paths
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
hsSourceCppOpts
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
target_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
backend_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
th_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
hscpp_opts
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
sse_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
avx_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
mb_macro_include
        -- 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.
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Option
SysTools.Option     FilePath
"-x"
                       , FilePath -> Option
SysTools.Option     FilePath
"assembler-with-cpp"
                       , FilePath -> Option
SysTools.Option     FilePath
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.
                       , FilePath -> Option
SysTools.Option     FilePath
"-o"
                       , FilePath -> FilePath -> Option
SysTools.FileOption FilePath
"" FilePath
output_fn
                       ])

getBackendDefs :: DynFlags -> IO [String]
getBackendDefs :: DynFlags -> IO [FilePath]
getBackendDefs DynFlags
dflags | DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscLlvm = do
    Maybe LlvmVersion
llvmVer <- DynFlags -> IO (Maybe LlvmVersion)
figureLlvmVersion DynFlags
dflags
    return $ case Maybe LlvmVersion
llvmVer of
#if MIN_GHC_API_VERSION(8,8,2)
               Just LlvmVersion
v
                 | [Int
m] <- LlvmVersion -> [Int]
llvmVersionList LlvmVersion
v -> [ FilePath
"-D__GLASGOW_HASKELL_LLVM__=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> FilePath
format (Int
m, Int
0) ]
                 | Int
m:Int
n:[Int]
_   <- LlvmVersion -> [Int]
llvmVersionList LlvmVersion
v -> [ FilePath
"-D__GLASGOW_HASKELL_LLVM__=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> FilePath
format (Int
m, Int
n) ]
#elif MIN_GHC_API_VERSION(8,8,0)
               Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
               Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
#else
               Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
#endif
               Maybe LlvmVersion
_      -> []
  where
    format :: (Int, Int) -> FilePath
format (Int
major, Int
minor)
      | Int
minor Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
100 = FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error FilePath
"getBackendDefs: Unsupported minor version"
      | Bool
otherwise = Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ (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

getBackendDefs DynFlags
_ =
    [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []

addOptP :: String -> DynFlags -> DynFlags
#if MIN_GHC_API_VERSION (8,10,0)
addOptP :: FilePath -> DynFlags -> DynFlags
addOptP FilePath
f = (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
alterToolSettings ((ToolSettings -> ToolSettings) -> DynFlags -> DynFlags)
-> (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ \ToolSettings
s -> ToolSettings
s
          { toolSettings_opt_P :: [FilePath]
toolSettings_opt_P             = FilePath
f FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: ToolSettings -> [FilePath]
toolSettings_opt_P ToolSettings
s
          , toolSettings_opt_P_fingerprint :: Fingerprint
toolSettings_opt_P_fingerprint = [FilePath] -> Fingerprint
fingerprintStrings (FilePath
f FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: ToolSettings -> [FilePath]
toolSettings_opt_P ToolSettings
s)
          }
  where
    fingerprintStrings :: [FilePath] -> Fingerprint
fingerprintStrings [FilePath]
ss = [Fingerprint] -> Fingerprint
fingerprintFingerprints ([Fingerprint] -> Fingerprint) -> [Fingerprint] -> Fingerprint
forall a b. (a -> b) -> a -> b
$ (FilePath -> Fingerprint) -> [FilePath] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Fingerprint
fingerprintString [FilePath]
ss
    alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags
alterToolSettings ToolSettings -> ToolSettings
f DynFlags
dynFlags = DynFlags
dynFlags { toolSettings :: ToolSettings
toolSettings = ToolSettings -> ToolSettings
f (DynFlags -> ToolSettings
toolSettings DynFlags
dynFlags) }
#else
addOptP opt = onSettings (onOptP (opt:))
  where
    onSettings f x = x{settings = f $ settings x}
    onOptP f x = x{sOpt_P = f $ sOpt_P x}
#endif

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

generatePackageVersionMacros :: [PackageConfig] -> String
generatePackageVersionMacros :: [PackageConfig] -> FilePath
generatePackageVersionMacros [PackageConfig]
pkgs = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  -- Do not add any C-style comments. See #3389.
  [ FilePath -> FilePath -> Version -> FilePath
generateMacros FilePath
"" FilePath
pkgname Version
version
  | PackageConfig
pkg <- [PackageConfig]
pkgs
  , let version :: Version
version = PackageConfig -> Version
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Version
packageVersion PackageConfig
pkg
        pkgname :: FilePath
pkgname = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
fixchar (PackageConfig -> FilePath
packageNameString PackageConfig
pkg)
  ]

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

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


-- | Find out path to @ghcversion.h@ file
getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName DynFlags
dflags = do
  [FilePath]
candidates <- case DynFlags -> Maybe FilePath
ghcVersionFile DynFlags
dflags of
    Just FilePath
path -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
path]
    Maybe FilePath
Nothing -> ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
</> FilePath
"ghcversion.h")) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               (DynFlags -> [PreloadUnitId] -> IO [FilePath]
getPackageIncludePath DynFlags
dflags [UnitId -> PreloadUnitId
toInstalledUnitId UnitId
rtsUnitId])

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