@@ -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
3+
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
7+
8+{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}
9+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
10+
11+-----------------------------------------------------------------------------
12+--
13+-- GHC Driver
14+--
15+-- (c) The University of Glasgow 2005
16+--
17+-----------------------------------------------------------------------------
18+
19+module Development.IDE.Functions.CPP(doCpp) where
20+
21+import Packages
22+import SysTools
23+import Module
24+import DynFlags
25+import Panic
26+import FileCleanup
27+
28+import System.Directory
29+import System.FilePath
30+import Control.Monad
31+import Data.List ( intercalate )
32+import Data.Maybe
33+import Data.Version
34+
35+
36+
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
41+
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
48+
49+ let verbFlags = getVerbFlags dflags
50+
51+ let cpp_prog args | raw = SysTools.runCpp dflags args
52+ | otherwise = SysTools.runCc Nothing dflags (SysTools.Option "-E" : args)
53+
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.
61+
62+ let sse_defs =
63+ [ "-D__SSE__" | isSseEnabled dflags ] ++
64+ [ "-D__SSE2__" | isSse2Enabled dflags ] ++
65+ [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
66+
67+ let avx_defs =
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 ]
74+
75+ backend_defs <- getBackendDefs dflags
76+
77+ let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
78+ -- Default CPP defines in Haskell source
79+ ghcVersionH <- getGhcVersionPathName dflags
80+ let hsSourceCppOpts = [ "-include", ghcVersionH ]
81+
82+ -- MIN_VERSION macros
83+ let uids = explicitPackages (pkgState dflags)
84+ pkgs = catMaybes (map (lookupPackage dflags) uids)
85+ mb_macro_include <-
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
93+ -- comment 8.
94+ return [SysTools.FileOption "-include" macro_stub]
95+ else return []
96+
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
106+ ++ mb_macro_include
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
110+ -- about this.
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
124+ ])
125+
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 ]
131+ _ -> []
132+ where
133+ format (major, minor)
134+ | minor >= 100 = error "getBackendDefs: Unsupported minor version"
135+ | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
136+
137+getBackendDefs _ =
138+ return []
139+
140+-- ---------------------------------------------------------------------------
141+-- Macros (cribbed from Cabal)
142+
143+generatePackageVersionMacros :: [PackageConfig] -> String
144+generatePackageVersionMacros pkgs = concat
145+ -- Do not add any C-style comments. See #3389.
146+ [ generateMacros "" pkgname version
147+ | pkg <- pkgs
148+ , let version = packageVersion pkg
149+ pkgname = map fixchar (packageNameString pkg)
150+ ]
151+
152+fixchar :: Char -> Char
153+fixchar '-' = '_'
154+fixchar c = c
155+
156+generateMacros :: String -> String -> Version -> String
157+generateMacros prefix name version =
158+ concat
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,")"
164+ ,"\n\n"
165+ ]
166+ where
167+ (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
168+
169+
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])
177+
178+ found <- filterM doesFileExist candidates
179+ case found of
180+ [] -> throwGhcExceptionIO (InstallationError
181+ ("ghcversion.h missing; tried: "
182+ ++ intercalate ", " candidates))
183+ (x:_) -> return x