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