71b9996cebebe3d37d64eabbb947d1e7e2cc9811
[ghc.git] / compiler / llvmGen / LlvmCodeGen.hs
1 {-# LANGUAGE CPP, TypeFamilies #-}
2
3 -- -----------------------------------------------------------------------------
4 -- | This is the top-level module in the LLVM code generator.
5 --
6 module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where
7
8 #include "HsVersions.h"
9
10 import Llvm
11 import LlvmCodeGen.Base
12 import LlvmCodeGen.CodeGen
13 import LlvmCodeGen.Data
14 import LlvmCodeGen.Ppr
15 import LlvmCodeGen.Regs
16 import LlvmMangler
17
18 import BlockId
19 import CgUtils ( fixStgRegisters )
20 import Cmm
21 import CmmUtils
22 import Hoopl.Block
23 import Hoopl.Collections
24 import PprCmm
25
26 import BufWrite
27 import DynFlags
28 import ErrUtils
29 import FastString
30 import Outputable
31 import UniqSupply
32 import SysTools ( figureLlvmVersion )
33 import qualified Stream
34
35 import Control.Monad ( when )
36 import Data.Maybe ( fromMaybe, catMaybes )
37 import System.IO
38
39 -- -----------------------------------------------------------------------------
40 -- | Top-level of the LLVM Code generator
41 --
42 llvmCodeGen :: DynFlags -> Handle -> UniqSupply
43 -> Stream.Stream IO RawCmmGroup ()
44 -> IO ()
45 llvmCodeGen dflags h us cmm_stream
46 = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do
47 bufh <- newBufHandle h
48
49 -- Pass header
50 showPass dflags "LLVM CodeGen"
51
52 -- get llvm version, cache for later use
53 ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags
54
55 -- warn if unsupported
56 debugTraceMsg dflags 2
57 (text "Using LLVM version:" <+> text (show ver))
58 let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
59 when (ver /= supportedLlvmVersion && doWarn) $
60 putMsg dflags (text "You are using an unsupported version of LLVM!"
61 $+$ text ("Currently only " ++
62 llvmVersionStr supportedLlvmVersion ++
63 " is supported.")
64 $+$ text "We will try though...")
65
66 -- run code generation
67 runLlvm dflags ver bufh us $
68 llvmCodeGen' (liftStream cmm_stream)
69
70 bFlush bufh
71
72 llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()
73 llvmCodeGen' cmm_stream
74 = do -- Preamble
75 renderLlvm pprLlvmHeader
76 ghcInternalFunctions
77 cmmMetaLlvmPrelude
78
79 -- Procedures
80 let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream
81 _ <- Stream.collect llvmStream
82
83 -- Declare aliases for forward references
84 renderLlvm . pprLlvmData =<< generateExternDecls
85
86 -- Postamble
87 cmmUsedLlvmGens
88
89 llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
90 llvmGroupLlvmGens cmm = do
91
92 -- Insert functions into map, collect data
93 let split (CmmData s d' ) = return $ Just (s, d')
94 split (CmmProc h l live g) = do
95 -- Set function type
96 let l' = case mapLookup (g_entry g) h of
97 Nothing -> l
98 Just (Statics info_lbl _) -> info_lbl
99 lml <- strCLabel_llvm l'
100 funInsert lml =<< llvmFunTy live
101 return Nothing
102 cdata <- fmap catMaybes $ mapM split cmm
103
104 {-# SCC "llvm_datas_gen" #-}
105 cmmDataLlvmGens cdata
106 {-# SCC "llvm_procs_gen" #-}
107 mapM_ cmmLlvmGen cmm
108
109 -- -----------------------------------------------------------------------------
110 -- | Do LLVM code generation on all these Cmms data sections.
111 --
112 cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()
113
114 cmmDataLlvmGens statics
115 = do lmdatas <- mapM genLlvmData statics
116
117 let (gss, tss) = unzip lmdatas
118
119 let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
120 = funInsert l ty
121 regGlobal _ = return ()
122 mapM_ regGlobal (concat gss)
123 gss' <- mapM aliasify $ concat gss
124
125 renderLlvm $ pprLlvmData (concat gss', concat tss)
126
127 -- | LLVM can't handle entry blocks which loop back to themselves (could be
128 -- seen as an LLVM bug) so we rearrange the code to keep the original entry
129 -- label which branches to a newly generated second label that branches back
130 -- to itself. See: Trac #11649
131 fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl
132 fixBottom cp@(CmmProc hdr entry_lbl live g) =
133 maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map
134 where
135 blk_map = toBlockMap g
136
137 fix_block :: CmmBlock -> LlvmM RawCmmDecl
138 fix_block blk
139 | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk
140 , isEmptyBlock middle
141 , e_lbl == b_lbl = do
142 new_lbl <- mkBlockId <$> getUniqueM
143
144 let fst_blk =
145 BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl)
146 snd_blk =
147 BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl)
148
149 pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g)
150 $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)]
151
152 fix_block _ = pure cp
153
154 fixBottom rcd = pure rcd
155
156 -- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
157 cmmLlvmGen ::RawCmmDecl -> LlvmM ()
158 cmmLlvmGen cmm@CmmProc{} = do
159
160 -- rewrite assignments to global regs
161 dflags <- getDynFlag id
162 fixed_cmm <- fixBottom $
163 {-# SCC "llvm_fix_regs" #-}
164 fixStgRegisters dflags cmm
165
166 dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
167
168 -- generate llvm code from cmm
169 llvmBC <- withClearVars $ genLlvmProc fixed_cmm
170
171 -- pretty print
172 (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
173
174 -- Output, note down used variables
175 renderLlvm (vcat docs)
176 mapM_ markUsedVar $ concat ivars
177
178 cmmLlvmGen _ = return ()
179
180 -- -----------------------------------------------------------------------------
181 -- | Generate meta data nodes
182 --
183
184 cmmMetaLlvmPrelude :: LlvmM ()
185 cmmMetaLlvmPrelude = do
186 metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
187 -- Generate / lookup meta data IDs
188 tbaaId <- getMetaUniqueId
189 setUniqMeta uniq tbaaId
190 parentId <- maybe (return Nothing) getUniqMeta parent
191 -- Build definition
192 return $ MetaUnnamed tbaaId $ MetaStruct $
193 case parentId of
194 Just p -> [ MetaStr name, MetaNode p ]
195 -- As of LLVM 4.0, a node without parents should be rendered as
196 -- just a name on its own. Previously `null` was accepted as the
197 -- name.
198 Nothing -> [ MetaStr name ]
199 renderLlvm $ ppLlvmMetas metas
200
201 -- -----------------------------------------------------------------------------
202 -- | Marks variables as used where necessary
203 --
204
205 cmmUsedLlvmGens :: LlvmM ()
206 cmmUsedLlvmGens = do
207
208 -- LLVM would discard variables that are internal and not obviously
209 -- used if we didn't provide these hints. This will generate a
210 -- definition of the form
211 --
212 -- @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]
213 --
214 -- Which is the LLVM way of protecting them against getting removed.
215 ivars <- getUsedVars
216 let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
217 ty = (LMArray (length ivars) i8Ptr)
218 usedArray = LMStaticArray (map cast ivars) ty
219 sectName = Just $ fsLit "llvm.metadata"
220 lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
221 lmUsed = LMGlobal lmUsedVar (Just usedArray)
222 if null ivars
223 then return ()
224 else renderLlvm $ pprLlvmData ([lmUsed], [])