Clean up opt and llc
[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 header
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 where
89 header :: SDoc
90 header = sdocWithDynFlags $ \dflags ->
91 let target = LLVM_TARGET
92 layout = case lookup target (llvmTargets dflags) of
93 Just (LlvmTarget dl _ _) -> dl
94 Nothing -> error $ "Failed to lookup the datalayout for " ++ target ++ "; available targets: " ++ show (map fst $ llvmTargets dflags)
95 in text ("target datalayout = \"" ++ layout ++ "\"")
96 $+$ text ("target triple = \"" ++ target ++ "\"")
97
98 llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
99 llvmGroupLlvmGens cmm = do
100
101 -- Insert functions into map, collect data
102 let split (CmmData s d' ) = return $ Just (s, d')
103 split (CmmProc h l live g) = do
104 -- Set function type
105 let l' = case mapLookup (g_entry g) h of
106 Nothing -> l
107 Just (Statics info_lbl _) -> info_lbl
108 lml <- strCLabel_llvm l'
109 funInsert lml =<< llvmFunTy live
110 return Nothing
111 cdata <- fmap catMaybes $ mapM split cmm
112
113 {-# SCC "llvm_datas_gen" #-}
114 cmmDataLlvmGens cdata
115 {-# SCC "llvm_procs_gen" #-}
116 mapM_ cmmLlvmGen cmm
117
118 -- -----------------------------------------------------------------------------
119 -- | Do LLVM code generation on all these Cmms data sections.
120 --
121 cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()
122
123 cmmDataLlvmGens statics
124 = do lmdatas <- mapM genLlvmData statics
125
126 let (gss, tss) = unzip lmdatas
127
128 let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
129 = funInsert l ty
130 regGlobal _ = return ()
131 mapM_ regGlobal (concat gss)
132 gss' <- mapM aliasify $ concat gss
133
134 renderLlvm $ pprLlvmData (concat gss', concat tss)
135
136 -- | LLVM can't handle entry blocks which loop back to themselves (could be
137 -- seen as an LLVM bug) so we rearrange the code to keep the original entry
138 -- label which branches to a newly generated second label that branches back
139 -- to itself. See: Trac #11649
140 fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl
141 fixBottom cp@(CmmProc hdr entry_lbl live g) =
142 maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map
143 where
144 blk_map = toBlockMap g
145
146 fix_block :: CmmBlock -> LlvmM RawCmmDecl
147 fix_block blk
148 | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk
149 , isEmptyBlock middle
150 , e_lbl == b_lbl = do
151 new_lbl <- mkBlockId <$> getUniqueM
152
153 let fst_blk =
154 BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl)
155 snd_blk =
156 BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl)
157
158 pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g)
159 $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)]
160
161 fix_block _ = pure cp
162
163 fixBottom rcd = pure rcd
164
165 -- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
166 cmmLlvmGen ::RawCmmDecl -> LlvmM ()
167 cmmLlvmGen cmm@CmmProc{} = do
168
169 -- rewrite assignments to global regs
170 dflags <- getDynFlag id
171 fixed_cmm <- fixBottom $
172 {-# SCC "llvm_fix_regs" #-}
173 fixStgRegisters dflags cmm
174
175 dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
176
177 -- generate llvm code from cmm
178 llvmBC <- withClearVars $ genLlvmProc fixed_cmm
179
180 -- pretty print
181 (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
182
183 -- Output, note down used variables
184 renderLlvm (vcat docs)
185 mapM_ markUsedVar $ concat ivars
186
187 cmmLlvmGen _ = return ()
188
189 -- -----------------------------------------------------------------------------
190 -- | Generate meta data nodes
191 --
192
193 cmmMetaLlvmPrelude :: LlvmM ()
194 cmmMetaLlvmPrelude = do
195 metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
196 -- Generate / lookup meta data IDs
197 tbaaId <- getMetaUniqueId
198 setUniqMeta uniq tbaaId
199 parentId <- maybe (return Nothing) getUniqMeta parent
200 -- Build definition
201 return $ MetaUnnamed tbaaId $ MetaStruct $
202 case parentId of
203 Just p -> [ MetaStr name, MetaNode p ]
204 -- As of LLVM 4.0, a node without parents should be rendered as
205 -- just a name on its own. Previously `null` was accepted as the
206 -- name.
207 Nothing -> [ MetaStr name ]
208 renderLlvm $ ppLlvmMetas metas
209
210 -- -----------------------------------------------------------------------------
211 -- | Marks variables as used where necessary
212 --
213
214 cmmUsedLlvmGens :: LlvmM ()
215 cmmUsedLlvmGens = do
216
217 -- LLVM would discard variables that are internal and not obviously
218 -- used if we didn't provide these hints. This will generate a
219 -- definition of the form
220 --
221 -- @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]
222 --
223 -- Which is the LLVM way of protecting them against getting removed.
224 ivars <- getUsedVars
225 let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
226 ty = (LMArray (length ivars) i8Ptr)
227 usedArray = LMStaticArray (map cast ivars) ty
228 sectName = Just $ fsLit "llvm.metadata"
229 lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
230 lmUsed = LMGlobal lmUsedVar (Just usedArray)
231 if null ivars
232 then return ()
233 else renderLlvm $ pprLlvmData ([lmUsed], [])