git.iko.soy/ghcide
on 210de4e help sign in
ghcide/src/Development/IDE/Functions/CPP.hs
184 lines 7.5 kB history raw
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-----------------------------------------------------------------------------
12--
13-- GHC Driver
14--
15-- (c) The University of Glasgow 2005
16--
17-----------------------------------------------------------------------------
19module Development.IDE.Functions.CPP(doCpp) where
21import Packages
22import SysTools
23import Module
24import DynFlags
25import Panic
26import FileCleanup
28import System.Directory
29import System.FilePath
30import Control.Monad
31import Data.List ( intercalate )
32import Data.Maybe
33import Data.Version
37doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
38doCpp 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
53 dflags (SysTools.Option "-E" : args)
55 let target_defs = [] {-
56 [ "-D" ++ HOST_OS ++ "_BUILD_OS",
57 "-D" ++ HOST_ARCH ++ "_BUILD_ARCH",
58 "-D" ++ TARGET_OS ++ "_HOST_OS",
59 "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ] -}
60 -- remember, in code we *compile*, the HOST is the same our TARGET,
61 -- and BUILD is the same as our HOST.
63 let sse_defs =
64 [ "-D__SSE__" | isSseEnabled dflags ] ++
65 [ "-D__SSE2__" | isSse2Enabled dflags ] ++
66 [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
68 let avx_defs =
69 [ "-D__AVX__" | isAvxEnabled dflags ] ++
70 [ "-D__AVX2__" | isAvx2Enabled dflags ] ++
71 [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
72 [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
73 [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
74 [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
76 backend_defs <- getBackendDefs dflags
78 let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
79 -- Default CPP defines in Haskell source
80 ghcVersionH <- getGhcVersionPathName dflags
81 let hsSourceCppOpts = [ "-include", ghcVersionH ]
83 -- MIN_VERSION macros
84 let uids = explicitPackages (pkgState dflags)
85 pkgs = catMaybes (map (lookupPackage dflags) uids)
86 mb_macro_include <-
87 if not (null pkgs) && gopt Opt_VersionMacros dflags
88 then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
89 writeFile macro_stub (generatePackageVersionMacros pkgs)
90 -- Include version macros for every *exposed* package.
91 -- Without -hide-all-packages and with a package database
92 -- size of 1000 packages, it takes cpp an estimated 2
93 -- milliseconds to process this file. See #10970
94 -- comment 8.
95 return [SysTools.FileOption "-include" macro_stub]
96 else return []
98 cpp_prog ( map SysTools.Option verbFlags
99 ++ map SysTools.Option include_paths
100 ++ map SysTools.Option hsSourceCppOpts
101 ++ map SysTools.Option target_defs
102 ++ map SysTools.Option backend_defs
103 ++ map SysTools.Option th_defs
104 ++ map SysTools.Option hscpp_opts
105 ++ map SysTools.Option sse_defs
106 ++ map SysTools.Option avx_defs
107 ++ mb_macro_include
108 -- Set the language mode to assembler-with-cpp when preprocessing. This
109 -- alleviates some of the C99 macro rules relating to whitespace and the hash
110 -- operator, which we tend to abuse. Clang in particular is not very happy
111 -- about this.
112 ++ [ SysTools.Option "-x"
113 , SysTools.Option "assembler-with-cpp"
114 , SysTools.Option input_fn
115 -- We hackily use Option instead of FileOption here, so that the file
116 -- name is not back-slashed on Windows. cpp is capable of
117 -- dealing with / in filenames, so it works fine. Furthermore
118 -- if we put in backslashes, cpp outputs #line directives
119 -- with *double* backslashes. And that in turn means that
120 -- our error messages get double backslashes in them.
121 -- In due course we should arrange that the lexer deals
122 -- with these \\ escapes properly.
123 , SysTools.Option "-o"
124 , SysTools.FileOption "" output_fn
125 ])
127getBackendDefs :: DynFlags -> IO [String]
128getBackendDefs dflags | hscTarget dflags == HscLlvm = do
129 llvmVer <- figureLlvmVersion dflags
130 return $ case llvmVer of
131 Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
132 _ -> []
133 where
134 format (major, minor)
135 | minor >= 100 = error "getBackendDefs: Unsupported minor version"
136 | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
138getBackendDefs _ =
139 return []
141-- ---------------------------------------------------------------------------
142-- Macros (cribbed from Cabal)
144generatePackageVersionMacros :: [PackageConfig] -> String
145generatePackageVersionMacros pkgs = concat
146 -- Do not add any C-style comments. See #3389.
147 [ generateMacros "" pkgname version
148 | pkg <- pkgs
149 , let version = packageVersion pkg
150 pkgname = map fixchar (packageNameString pkg)
151 ]
153fixchar :: Char -> Char
154fixchar '-' = '_'
155fixchar c = c
157generateMacros :: String -> String -> Version -> String
158generateMacros prefix name version =
159 concat
160 ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
161 ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
162 ," (major1) < ",major1," || \\\n"
163 ," (major1) == ",major1," && (major2) < ",major2," || \\\n"
164 ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
165 ,"\n\n"
166 ]
167 where
168 (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
171-- | Find out path to @ghcversion.h@ file
172getGhcVersionPathName :: DynFlags -> IO FilePath
173getGhcVersionPathName dflags = do
174 candidates <- case ghcVersionFile dflags of
175 Just path -> return [path]
176 Nothing -> (map (</> "ghcversion.h")) <$>
177 (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])
179 found <- filterM doesFileExist candidates
180 case found of
181 [] -> throwGhcExceptionIO (InstallationError
182 ("ghcversion.h missing; tried: "
183 ++ intercalate ", " candidates))
184 (x:_) -> return x