@@ -0,0 +1,183 @@
1+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2+-- SPDX-License-Identifier: Apache-2.0
4+-- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019
5+-- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944
6+{- HLINT ignore -} -- since copied from upstream
8+{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}
9+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
11+-----------------------------------------------------------------------------
15+-- (c) The University of Glasgow 2005
17+-----------------------------------------------------------------------------
19+module Development.IDE.Functions.CPP(doCpp) where
28+import System.Directory
29+import System.FilePath
31+import Data.List ( intercalate )
37+doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
38+doCpp dflags raw input_fn output_fn = do
39+ let hscpp_opts = picPOpts dflags
40+ let cmdline_include_paths = includePaths dflags
42+ pkg_include_dirs <- getPackageIncludePath dflags []
43+ let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
44+ (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
45+ let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
46+ (includePathsQuote cmdline_include_paths)
47+ let include_paths = include_paths_quote ++ include_paths_global
49+ let verbFlags = getVerbFlags dflags
51+ let cpp_prog args | raw = SysTools.runCpp dflags args
52+ | otherwise = SysTools.runCc Nothing dflags (SysTools.Option "-E" : args)
54+ let target_defs = [] {-
55+ [ "-D" ++ HOST_OS ++ "_BUILD_OS",
56+ "-D" ++ HOST_ARCH ++ "_BUILD_ARCH",
57+ "-D" ++ TARGET_OS ++ "_HOST_OS",
58+ "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ] -}
59+ -- remember, in code we *compile*, the HOST is the same our TARGET,
60+ -- and BUILD is the same as our HOST.
63+ [ "-D__SSE__" | isSseEnabled dflags ] ++
64+ [ "-D__SSE2__" | isSse2Enabled dflags ] ++
65+ [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
68+ [ "-D__AVX__" | isAvxEnabled dflags ] ++
69+ [ "-D__AVX2__" | isAvx2Enabled dflags ] ++
70+ [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
71+ [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
72+ [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
73+ [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
75+ backend_defs <- getBackendDefs dflags
77+ let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
78+ -- Default CPP defines in Haskell source
79+ ghcVersionH <- getGhcVersionPathName dflags
80+ let hsSourceCppOpts = [ "-include", ghcVersionH ]
82+ -- MIN_VERSION macros
83+ let uids = explicitPackages (pkgState dflags)
84+ pkgs = catMaybes (map (lookupPackage dflags) uids)
86+ if not (null pkgs) && gopt Opt_VersionMacros dflags
87+ then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
88+ writeFile macro_stub (generatePackageVersionMacros pkgs)
89+ -- Include version macros for every *exposed* package.
90+ -- Without -hide-all-packages and with a package database
91+ -- size of 1000 packages, it takes cpp an estimated 2
92+ -- milliseconds to process this file. See #10970
94+ return [SysTools.FileOption "-include" macro_stub]
97+ cpp_prog ( map SysTools.Option verbFlags
98+ ++ map SysTools.Option include_paths
99+ ++ map SysTools.Option hsSourceCppOpts
100+ ++ map SysTools.Option target_defs
101+ ++ map SysTools.Option backend_defs
102+ ++ map SysTools.Option th_defs
103+ ++ map SysTools.Option hscpp_opts
104+ ++ map SysTools.Option sse_defs
105+ ++ map SysTools.Option avx_defs
107+ -- Set the language mode to assembler-with-cpp when preprocessing. This
108+ -- alleviates some of the C99 macro rules relating to whitespace and the hash
109+ -- operator, which we tend to abuse. Clang in particular is not very happy
111+ ++ [ SysTools.Option "-x"
112+ , SysTools.Option "assembler-with-cpp"
113+ , SysTools.Option input_fn
114+ -- We hackily use Option instead of FileOption here, so that the file
115+ -- name is not back-slashed on Windows. cpp is capable of
116+ -- dealing with / in filenames, so it works fine. Furthermore
117+ -- if we put in backslashes, cpp outputs #line directives
118+ -- with *double* backslashes. And that in turn means that
119+ -- our error messages get double backslashes in them.
120+ -- In due course we should arrange that the lexer deals
121+ -- with these \\ escapes properly.
122+ , SysTools.Option "-o"
123+ , SysTools.FileOption "" output_fn
126+getBackendDefs :: DynFlags -> IO [String]
127+getBackendDefs dflags | hscTarget dflags == HscLlvm = do
128+ llvmVer <- figureLlvmVersion dflags
129+ return $ case llvmVer of
130+ Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
133+ format (major, minor)
134+ | minor >= 100 = error "getBackendDefs: Unsupported minor version"
135+ | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
140+-- ---------------------------------------------------------------------------
141+-- Macros (cribbed from Cabal)
143+generatePackageVersionMacros :: [PackageConfig] -> String
144+generatePackageVersionMacros pkgs = concat
145+ -- Do not add any C-style comments. See #3389.
146+ [ generateMacros "" pkgname version
148+ , let version = packageVersion pkg
149+ pkgname = map fixchar (packageNameString pkg)
152+fixchar :: Char -> Char
156+generateMacros :: String -> String -> Version -> String
157+generateMacros prefix name version =
159+ ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
160+ ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
161+ ," (major1) < ",major1," || \\\n"
162+ ," (major1) == ",major1," && (major2) < ",major2," || \\\n"
163+ ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
167+ (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
170+-- | Find out path to @ghcversion.h@ file
171+getGhcVersionPathName :: DynFlags -> IO FilePath
172+getGhcVersionPathName dflags = do
173+ candidates <- case ghcVersionFile dflags of
174+ Just path -> return [path]
175+ Nothing -> (map (</> "ghcversion.h")) <$>
176+ (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])
178+ found <- filterM doesFileExist candidates
180+ [] -> throwGhcExceptionIO (InstallationError
181+ ("ghcversion.h missing; tried: "
182+ ++ intercalate ", " candidates))