never executed always true always false
1 {-# LANGUAGE TypeFamilies, ViewPatterns, OverloadedStrings #-}
2
3 -- -----------------------------------------------------------------------------
4 -- | This is the top-level module in the LLVM code generator.
5 --
6 module GHC.CmmToLlvm
7 ( LlvmVersion
8 , llvmVersionList
9 , llvmCodeGen
10 , llvmFixupAsm
11 )
12 where
13
14 import GHC.Prelude
15
16 import GHC.Llvm
17 import GHC.CmmToLlvm.Base
18 import GHC.CmmToLlvm.CodeGen
19 import GHC.CmmToLlvm.Data
20 import GHC.CmmToLlvm.Ppr
21 import GHC.CmmToLlvm.Regs
22 import GHC.CmmToLlvm.Mangler
23
24 import GHC.StgToCmm.CgUtils ( fixStgRegisters )
25 import GHC.Cmm
26 import GHC.Cmm.Dataflow.Collections
27 import GHC.Cmm.Ppr
28
29 import GHC.Utils.BufHandle
30 import GHC.Driver.Session
31 import GHC.Platform ( platformArch, Arch(..) )
32 import GHC.Utils.Error
33 import GHC.Data.FastString
34 import GHC.Utils.Outputable
35 import GHC.Utils.Panic
36 import GHC.Utils.Logger
37 import GHC.SysTools ( figureLlvmVersion )
38 import qualified GHC.Data.Stream as Stream
39
40 import Control.Monad ( when, forM_ )
41 import Data.Maybe ( fromMaybe, catMaybes )
42 import System.IO
43
44 -- -----------------------------------------------------------------------------
45 -- | Top-level of the LLVM Code generator
46 --
47 llvmCodeGen :: Logger -> DynFlags -> Handle
48 -> Stream.Stream IO RawCmmGroup a
49 -> IO a
50 llvmCodeGen logger dflags h cmm_stream
51 = withTiming logger (text "LLVM CodeGen") (const ()) $ do
52 bufh <- newBufHandle h
53
54 -- Pass header
55 showPass logger "LLVM CodeGen"
56
57 -- get llvm version, cache for later use
58 mb_ver <- figureLlvmVersion logger dflags
59
60 -- warn if unsupported
61 forM_ mb_ver $ \ver -> do
62 debugTraceMsg logger 2
63 (text "Using LLVM version:" <+> text (llvmVersionStr ver))
64 let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
65 when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger $
66 "You are using an unsupported version of LLVM!" $$
67 "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+>
68 "to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "is supported." <+>
69 "System LLVM version: " <> text (llvmVersionStr ver) $$
70 "We will try though..."
71 let isS390X = platformArch (targetPlatform dflags) == ArchS390X
72 let major_ver = head . llvmVersionList $ ver
73 when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $
74 "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>
75 "You are using LLVM version: " <> text (llvmVersionStr ver)
76
77 -- HACK: the Nothing case here is potentially wrong here but we
78 -- currently don't use the LLVM version to guide code generation
79 -- so this is okay.
80 let llvm_ver :: LlvmVersion
81 llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver
82
83 -- run code generation
84 a <- runLlvm logger dflags llvm_ver bufh $
85 llvmCodeGen' dflags cmm_stream
86
87 bFlush bufh
88
89 return a
90
91 llvmCodeGen' :: DynFlags -> Stream.Stream IO RawCmmGroup a -> LlvmM a
92 llvmCodeGen' dflags cmm_stream
93 = do -- Preamble
94 renderLlvm header
95 ghcInternalFunctions
96 cmmMetaLlvmPrelude
97
98 -- Procedures
99 a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens
100
101 -- Declare aliases for forward references
102 opts <- getLlvmOpts
103 renderLlvm . pprLlvmData opts =<< generateExternDecls
104
105 -- Postamble
106 cmmUsedLlvmGens
107
108 return a
109 where
110 header :: SDoc
111 header =
112 let target = platformMisc_llvmTarget $ platformMisc dflags
113 in text ("target datalayout = \"" ++ getDataLayout (llvmConfig dflags) target ++ "\"")
114 $+$ text ("target triple = \"" ++ target ++ "\"")
115
116 getDataLayout :: LlvmConfig -> String -> String
117 getDataLayout config target =
118 case lookup target (llvmTargets config) of
119 Just (LlvmTarget {lDataLayout=dl}) -> dl
120 Nothing -> pprPanic "Failed to lookup LLVM data layout" $
121 text "Target:" <+> text target $$
122 hang (text "Available targets:") 4
123 (vcat $ map (text . fst) $ llvmTargets config)
124
125 llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
126 llvmGroupLlvmGens cmm = do
127
128 -- Insert functions into map, collect data
129 let split (CmmData s d' ) = return $ Just (s, d')
130 split (CmmProc h l live g) = do
131 -- Set function type
132 let l' = case mapLookup (g_entry g) h :: Maybe RawCmmStatics of
133 Nothing -> l
134 Just (CmmStaticsRaw info_lbl _) -> info_lbl
135 lml <- strCLabel_llvm l'
136 funInsert lml =<< llvmFunTy live
137 return Nothing
138 cdata <- fmap catMaybes $ mapM split cmm
139
140 {-# SCC "llvm_datas_gen" #-}
141 cmmDataLlvmGens cdata
142 {-# SCC "llvm_procs_gen" #-}
143 mapM_ cmmLlvmGen cmm
144
145 -- -----------------------------------------------------------------------------
146 -- | Do LLVM code generation on all these Cmms data sections.
147 --
148 cmmDataLlvmGens :: [(Section,RawCmmStatics)] -> LlvmM ()
149
150 cmmDataLlvmGens statics
151 = do lmdatas <- mapM genLlvmData statics
152
153 let (concat -> gs, tss) = unzip lmdatas
154
155 let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
156 = funInsert l ty
157 regGlobal _ = pure ()
158 mapM_ regGlobal gs
159 gss' <- mapM aliasify $ gs
160
161 opts <- getLlvmOpts
162 renderLlvm $ pprLlvmData opts (concat gss', concat tss)
163
164 -- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
165 cmmLlvmGen ::RawCmmDecl -> LlvmM ()
166 cmmLlvmGen cmm@CmmProc{} = do
167
168 -- rewrite assignments to global regs
169 platform <- getPlatform
170 let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters platform cmm
171
172 dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm"
173 FormatCMM (pprCmmGroup platform [fixed_cmm])
174
175 -- generate llvm code from cmm
176 llvmBC <- withClearVars $ genLlvmProc fixed_cmm
177
178 -- pretty print
179 (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
180
181 -- Output, note down used variables
182 renderLlvm (vcat docs)
183 mapM_ markUsedVar $ concat ivars
184
185 cmmLlvmGen _ = return ()
186
187 -- -----------------------------------------------------------------------------
188 -- | Generate meta data nodes
189 --
190
191 cmmMetaLlvmPrelude :: LlvmM ()
192 cmmMetaLlvmPrelude = do
193 metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
194 -- Generate / lookup meta data IDs
195 tbaaId <- getMetaUniqueId
196 setUniqMeta uniq tbaaId
197 parentId <- maybe (return Nothing) getUniqMeta parent
198 -- Build definition
199 return $ MetaUnnamed tbaaId $ MetaStruct $
200 case parentId of
201 Just p -> [ MetaStr name, MetaNode p ]
202 -- As of LLVM 4.0, a node without parents should be rendered as
203 -- just a name on its own. Previously `null` was accepted as the
204 -- name.
205 Nothing -> [ MetaStr name ]
206 opts <- getLlvmOpts
207 renderLlvm $ ppLlvmMetas opts metas
208
209 -- -----------------------------------------------------------------------------
210 -- | Marks variables as used where necessary
211 --
212
213 cmmUsedLlvmGens :: LlvmM ()
214 cmmUsedLlvmGens = do
215
216 -- LLVM would discard variables that are internal and not obviously
217 -- used if we didn't provide these hints. This will generate a
218 -- definition of the form
219 --
220 -- @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]
221 --
222 -- Which is the LLVM way of protecting them against getting removed.
223 ivars <- getUsedVars
224 let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
225 ty = (LMArray (length ivars) i8Ptr)
226 usedArray = LMStaticArray (map cast ivars) ty
227 sectName = Just $ fsLit "llvm.metadata"
228 lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
229 lmUsed = LMGlobal lmUsedVar (Just usedArray)
230 opts <- getLlvmOpts
231 if null ivars
232 then return ()
233 else renderLlvm $ pprLlvmData opts ([lmUsed], [])