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