ghcide-0.1.0: src/Development/IDE/GHC/CPP.hs
-- 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, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}
{-# 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) where
import Development.IDE.GHC.Compat
import Packages
import SysTools
import Module
import DynFlags
import Panic
import FileCleanup
#if MIN_GHC_API_VERSION(8,8,2)
import LlvmCodeGen (llvmVersionList)
#elif MIN_GHC_API_VERSION(8,8,0)
import LlvmCodeGen (LlvmVersion (..))
#endif
import System.Directory
import System.FilePath
import Control.Monad
import System.Info
import Data.List ( intercalate )
import Data.Maybe
import Data.Version
doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp dflags raw input_fn output_fn = do
let hscpp_opts = picPOpts dflags
let cmdline_include_paths = includePaths dflags
pkg_include_dirs <- getPackageIncludePath dflags []
let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
(includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
(includePathsQuote cmdline_include_paths)
let include_paths = include_paths_quote ++ include_paths_global
let verbFlags = getVerbFlags dflags
let cpp_prog args | raw = SysTools.runCpp dflags args
| otherwise = SysTools.runCc
dflags (SysTools.Option "-E" : args)
let target_defs =
-- NEIL: Patched to use System.Info instead of constants from CPP
[ "-D" ++ os ++ "_BUILD_OS",
"-D" ++ arch ++ "_BUILD_ARCH",
"-D" ++ os ++ "_HOST_OS",
"-D" ++ arch ++ "_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 =
[ "-D__SSE__" | isSseEnabled dflags ] ++
[ "-D__SSE2__" | isSse2Enabled dflags ] ++
[ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
let avx_defs =
[ "-D__AVX__" | isAvxEnabled dflags ] ++
[ "-D__AVX2__" | isAvx2Enabled dflags ] ++
[ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
[ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
[ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
[ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
backend_defs <- getBackendDefs dflags
let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
-- Default CPP defines in Haskell source
ghcVersionH <- getGhcVersionPathName dflags
let hsSourceCppOpts = [ "-include", ghcVersionH ]
-- MIN_VERSION macros
let uids = explicitPackages (pkgState dflags)
pkgs = catMaybes (map (lookupPackage dflags) uids)
mb_macro_include <-
if not (null pkgs) && gopt Opt_VersionMacros dflags
then do macro_stub <- newTempName 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 [SysTools.FileOption "-include" macro_stub]
else return []
cpp_prog ( map SysTools.Option verbFlags
++ map SysTools.Option include_paths
++ map SysTools.Option hsSourceCppOpts
++ map SysTools.Option target_defs
++ map SysTools.Option backend_defs
++ map SysTools.Option th_defs
++ map SysTools.Option hscpp_opts
++ map SysTools.Option sse_defs
++ map SysTools.Option avx_defs
++ 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.
++ [ SysTools.Option "-x"
, SysTools.Option "assembler-with-cpp"
, 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.
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
])
getBackendDefs :: DynFlags -> IO [String]
getBackendDefs dflags | hscTarget dflags == HscLlvm = do
llvmVer <- figureLlvmVersion dflags
return $ case llvmVer of
#if MIN_GHC_API_VERSION(8,8,2)
Just v
| [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]
| m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 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
_ -> []
where
format (major, minor)
| minor >= 100 = error "getBackendDefs: Unsupported minor version"
| otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
getBackendDefs _ =
return []
-- ---------------------------------------------------------------------------
-- Macros (cribbed from Cabal)
generatePackageVersionMacros :: [PackageConfig] -> String
generatePackageVersionMacros pkgs = concat
-- Do not add any C-style comments. See #3389.
[ generateMacros "" pkgname version
| pkg <- pkgs
, let version = packageVersion pkg
pkgname = map fixchar (packageNameString pkg)
]
fixchar :: Char -> Char
fixchar '-' = '_'
fixchar c = c
generateMacros :: String -> String -> Version -> String
generateMacros prefix name version =
concat
["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
," (major1) < ",major1," || \\\n"
," (major1) == ",major1," && (major2) < ",major2," || \\\n"
," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
,"\n\n"
]
where
(major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
-- | Find out path to @ghcversion.h@ file
getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName dflags = do
candidates <- case ghcVersionFile dflags of
Just path -> return [path]
Nothing -> (map (</> "ghcversion.h")) <$>
(getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])
found <- filterM doesFileExist candidates
case found of
[] -> throwGhcExceptionIO (InstallationError
("ghcversion.h missing; tried: "
++ intercalate ", " candidates))
(x:_) -> return x