3a7c05b53587a7bc66adcba950bc6bd728ba3018
[ghc.git] / compiler / llvmGen / LlvmCodeGen / CodeGen.hs
1 {-# LANGUAGE CPP, GADTs #-}
2 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
3 -- ----------------------------------------------------------------------------
4 -- | Handle conversion of CmmProc to LLVM code.
5 --
6 module LlvmCodeGen.CodeGen ( genLlvmProc ) where
7
8 #include "HsVersions.h"
9
10 import Llvm
11 import LlvmCodeGen.Base
12 import LlvmCodeGen.Regs
13
14 import BlockId
15 import CodeGen.Platform ( activeStgRegs, callerSaves )
16 import CLabel
17 import Cmm
18 import CPrim
19 import PprCmm
20 import CmmUtils
21 import CmmSwitch
22 import Hoopl
23
24 import DynFlags
25 import FastString
26 import ForeignCall
27 import Outputable
28 import Platform
29 import OrdList
30 import UniqSupply
31 import Unique
32
33 import Data.List ( nub )
34 import Data.Maybe ( catMaybes )
35
36 type Atomic = Bool
37 type LlvmStatements = OrdList LlvmStatement
38
39 -- -----------------------------------------------------------------------------
40 -- | Top-level of the LLVM proc Code generator
41 --
42 genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
43 genLlvmProc (CmmProc infos lbl live graph) = do
44 let blocks = toBlockListEntryFirstFalseFallthrough graph
45 (lmblocks, lmdata) <- basicBlocksCodeGen live blocks
46 let info = mapLookup (g_entry graph) infos
47 proc = CmmProc info lbl live (ListGraph lmblocks)
48 return (proc:lmdata)
49
50 genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!"
51
52 -- -----------------------------------------------------------------------------
53 -- * Block code generation
54 --
55
56 -- | Generate code for a list of blocks that make up a complete
57 -- procedure. The first block in the list is exepected to be the entry
58 -- point and will get the prologue.
59 basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]
60 -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
61 basicBlocksCodeGen _ [] = panic "no entry block!"
62 basicBlocksCodeGen live (entryBlock:cmmBlocks)
63 = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks)
64
65 -- Generate code
66 (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock
67 (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks
68
69 -- Compose
70 let entryBlock = BasicBlock bid (fromOL prologue ++ entry)
71 return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss)
72
73
74 -- | Generate code for one block
75 basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
76 basicBlockCodeGen block
77 = do let (_, nodes, tail) = blockSplit block
78 id = entryLabel block
79 (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes
80 (tail_instrs, top') <- stmtToInstrs tail
81 let instrs = fromOL (mid_instrs `appOL` tail_instrs)
82 return (BasicBlock id instrs, top' ++ top)
83
84 -- -----------------------------------------------------------------------------
85 -- * CmmNode code generation
86 --
87
88 -- A statement conversion return data.
89 -- * LlvmStatements: The compiled LLVM statements.
90 -- * LlvmCmmDecl: Any global data needed.
91 type StmtData = (LlvmStatements, [LlvmCmmDecl])
92
93
94 -- | Convert a list of CmmNode's to LlvmStatement's
95 stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData
96 stmtsToInstrs stmts
97 = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts
98 return (concatOL instrss, concat topss)
99
100
101 -- | Convert a CmmStmt to a list of LlvmStatement's
102 stmtToInstrs :: CmmNode e x -> LlvmM StmtData
103 stmtToInstrs stmt = case stmt of
104
105 CmmComment _ -> return (nilOL, []) -- nuke comments
106 CmmTick _ -> return (nilOL, [])
107 CmmUnwind {} -> return (nilOL, [])
108
109 CmmAssign reg src -> genAssign reg src
110 CmmStore addr src -> genStore addr src
111
112 CmmBranch id -> genBranch id
113 CmmCondBranch arg true false
114 -> genCondBranch arg true false
115 CmmSwitch arg ids -> genSwitch arg ids
116
117 -- Foreign Call
118 CmmUnsafeForeignCall target res args
119 -> genCall target res args
120
121 -- Tail call
122 CmmCall { cml_target = arg,
123 cml_args_regs = live } -> genJump arg live
124
125 _ -> panic "Llvm.CodeGen.stmtToInstrs"
126
127 -- | Wrapper function to declare an instrinct function by function type
128 getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData
129 getInstrinct2 fname fty@(LMFunction funSig) = do
130
131 let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant
132
133 fn <- funLookup fname
134 tops <- case fn of
135 Just _ ->
136 return []
137 Nothing -> do
138 funInsert fname fty
139 return [CmmData Data [([],[fty])]]
140
141 return (fv, nilOL, tops)
142
143 getInstrinct2 _ _ = error "getInstrinct2: Non-function type!"
144
145 -- | Declares an instrinct function by return and parameter types
146 getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
147 getInstrinct fname retTy parTys =
148 let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy
149 FixedArgs (tysToParams parTys) Nothing
150 fty = LMFunction funSig
151 in getInstrinct2 fname fty
152
153 -- | Memory barrier instruction for LLVM >= 3.0
154 barrier :: LlvmM StmtData
155 barrier = do
156 let s = Fence False SyncSeqCst
157 return (unitOL s, [])
158
159 -- | Memory barrier instruction for LLVM < 3.0
160 oldBarrier :: LlvmM StmtData
161 oldBarrier = do
162
163 (fv, _, tops) <- getInstrinct (fsLit "llvm.memory.barrier") LMVoid [i1, i1, i1, i1, i1]
164
165 let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue]
166 let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs
167
168 return (unitOL s1, tops)
169
170 where
171 lmTrue :: LlvmVar
172 lmTrue = mkIntLit i1 (-1)
173
174 -- | Foreign Calls
175 genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]
176 -> LlvmM StmtData
177
178 -- Write barrier needs to be handled specially as it is implemented as an LLVM
179 -- intrinsic function.
180 genCall (PrimTarget MO_WriteBarrier) _ _ = do
181 platform <- getLlvmPlatform
182 ver <- getLlvmVer
183 case () of
184 _ | platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC]
185 -> return (nilOL, [])
186 | ver > 29 -> barrier
187 | otherwise -> oldBarrier
188
189 genCall (PrimTarget MO_Touch) _ _
190 = return (nilOL, [])
191
192 genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = do
193 dstV <- getCmmReg (CmmLocal dst)
194 let ty = cmmToLlvmType $ localRegType dst
195 width = widthToLlvmFloat w
196 castV <- mkLocalVar ty
197 (ve, stmts, top) <- exprToVar e
198 let stmt3 = Assignment castV $ Cast LM_Uitofp ve width
199 stmt4 = Store castV dstV
200 return (stmts `snocOL` stmt3 `snocOL` stmt4, top)
201
202 genCall (PrimTarget (MO_UF_Conv _)) [_] args =
203 panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
204 "Can only handle 1, given" ++ show (length args) ++ "."
205
206 -- Handle prefetching data
207 genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args
208 | 0 <= localityInt && localityInt <= 3 = do
209 ver <- getLlvmVer
210 let argTy | ver <= 29 = [i8Ptr, i32, i32]
211 | otherwise = [i8Ptr, i32, i32, i32]
212 funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
213 CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
214
215 let (_, arg_hints) = foreignTargetHints t
216 let args_hints' = zip args arg_hints
217 (argVars, stmts1, top1) <- arg_vars args_hints' ([], nilOL, [])
218 (fptr, stmts2, top2) <- getFunPtr funTy t
219 (argVars', stmts3) <- castVars $ zip argVars argTy
220
221 trash <- getTrashStmts
222 let argSuffix | ver <= 29 = [mkIntLit i32 0, mkIntLit i32 localityInt]
223 | otherwise = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1]
224 call = Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
225 stmts = stmts1 `appOL` stmts2 `appOL` stmts3
226 `appOL` trash `snocOL` call
227 return (stmts, top1 ++ top2)
228 | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt)
229
230 -- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg
231 -- and return types
232 genCall t@(PrimTarget (MO_PopCnt w)) dsts args =
233 genCallSimpleCast w t dsts args
234 genCall t@(PrimTarget (MO_Clz w)) dsts args =
235 genCallSimpleCast w t dsts args
236 genCall t@(PrimTarget (MO_Ctz w)) dsts args =
237 genCallSimpleCast w t dsts args
238 genCall t@(PrimTarget (MO_BSwap w)) dsts args =
239 genCallSimpleCast w t dsts args
240
241 genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = do
242 dstV <- getCmmReg (CmmLocal dst)
243 (v1, stmts, top) <- genLoad True addr (localRegType dst)
244 let stmt1 = Store v1 dstV
245 return (stmts `snocOL` stmt1, top)
246
247 -- TODO: implement these properly rather than calling to RTS functions.
248 -- genCall t@(PrimTarget (MO_AtomicWrite width)) [] [addr, val] = undefined
249 -- genCall t@(PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = undefined
250 -- genCall t@(PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] = undefined
251
252 -- Handle memcpy function specifically since llvm's intrinsic version takes
253 -- some extra parameters.
254 genCall t@(PrimTarget op) [] args'
255 | op == MO_Memcpy ||
256 op == MO_Memset ||
257 op == MO_Memmove = do
258 ver <- getLlvmVer
259 dflags <- getDynFlags
260 let (args, alignVal) = splitAlignVal args'
261 (isVolTy, isVolVal)
262 | ver >= 28 = ([i1], [mkIntLit i1 0])
263 | otherwise = ([], [])
264 argTy | op == MO_Memset = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy
265 | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy
266 funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
267 CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
268
269 let (_, arg_hints) = foreignTargetHints t
270 let args_hints = zip args arg_hints
271 (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, [])
272 (fptr, stmts2, top2) <- getFunPtr funTy t
273 (argVars', stmts3) <- castVars $ zip argVars argTy
274
275 stmts4 <- getTrashStmts
276 let arguments = argVars' ++ (alignVal:isVolVal)
277 call = Expr $ Call StdCall fptr arguments []
278 stmts = stmts1 `appOL` stmts2 `appOL` stmts3
279 `appOL` stmts4 `snocOL` call
280 return (stmts, top1 ++ top2)
281 where
282 splitAlignVal xs = (init xs, extractLit $ last xs)
283
284 -- Fix for trac #6158. Since LLVM 3.1, opt fails when given anything other
285 -- than a direct constant (i.e. 'i32 8') as the alignment argument for the
286 -- memcpy & co llvm intrinsic functions. So we handle this directly now.
287 extractLit (CmmLit (CmmInt i _)) = mkIntLit i32 i
288 extractLit _other = trace ("WARNING: Non constant alignment value given" ++
289 " for memcpy! Please report to GHC developers")
290 mkIntLit i32 0
291
292 -- Handle all other foreign calls and prim ops.
293 genCall target res args = do
294
295 dflags <- getDynFlags
296
297 -- parameter types
298 let arg_type (_, AddrHint) = i8Ptr
299 -- cast pointers to i8*. Llvm equivalent of void*
300 arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr
301
302 -- ret type
303 let ret_type [] = LMVoid
304 ret_type [(_, AddrHint)] = i8Ptr
305 ret_type [(reg, _)] = cmmToLlvmType $ localRegType reg
306 ret_type t = panic $ "genCall: Too many return values! Can only handle"
307 ++ " 0 or 1, given " ++ show (length t) ++ "."
308
309 -- extract Cmm call convention, and translate to LLVM call convention
310 platform <- getLlvmPlatform
311 let lmconv = case target of
312 ForeignTarget _ (ForeignConvention conv _ _ _) ->
313 case conv of
314 StdCallConv -> case platformArch platform of
315 ArchX86 -> CC_X86_Stdcc
316 ArchX86_64 -> CC_X86_Stdcc
317 _ -> CC_Ccc
318 CCallConv -> CC_Ccc
319 CApiConv -> CC_Ccc
320 PrimCallConv -> panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv"
321 JavaScriptCallConv -> panic "LlvmCodeGen.CodeGen.genCall: JavaScriptCallConv"
322
323 PrimTarget _ -> CC_Ccc
324
325 {-
326 CC_Ccc of the possibilities here are a worry with the use of a custom
327 calling convention for passing STG args. In practice the more
328 dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
329
330 The native code generator only handles StdCall and CCallConv.
331 -}
332
333 -- call attributes
334 let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs
335 | otherwise = llvmStdFunAttrs
336
337 never_returns = case target of
338 ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True
339 _ -> False
340
341 -- fun type
342 let (res_hints, arg_hints) = foreignTargetHints target
343 let args_hints = zip args arg_hints
344 let ress_hints = zip res res_hints
345 let ccTy = StdCall -- tail calls should be done through CmmJump
346 let retTy = ret_type ress_hints
347 let argTy = tysToParams $ map arg_type args_hints
348 let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
349 lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
350
351
352 (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, [])
353 (fptr, stmts2, top2) <- getFunPtr funTy target
354
355 let retStmt | ccTy == TailCall = unitOL $ Return Nothing
356 | never_returns = unitOL $ Unreachable
357 | otherwise = nilOL
358
359 stmts3 <- getTrashStmts
360 let stmts = stmts1 `appOL` stmts2 `appOL` stmts3
361
362 -- make the actual call
363 case retTy of
364 LMVoid -> do
365 let s1 = Expr $ Call ccTy fptr argVars fnAttrs
366 let allStmts = stmts `snocOL` s1 `appOL` retStmt
367 return (allStmts, top1 ++ top2)
368
369 _ -> do
370 (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
371 -- get the return register
372 let ret_reg [reg] = reg
373 ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
374 ++ " 1, given " ++ show (length t) ++ "."
375 let creg = ret_reg res
376 vreg <- getCmmReg (CmmLocal creg)
377 let allStmts = stmts `snocOL` s1
378 if retTy == pLower (getVarType vreg)
379 then do
380 let s2 = Store v1 vreg
381 return (allStmts `snocOL` s2 `appOL` retStmt,
382 top1 ++ top2)
383 else do
384 let ty = pLower $ getVarType vreg
385 let op = case ty of
386 vt | isPointer vt -> LM_Bitcast
387 | isInt vt -> LM_Ptrtoint
388 | otherwise ->
389 panic $ "genCall: CmmReg bad match for"
390 ++ " returned type!"
391
392 (v2, s2) <- doExpr ty $ Cast op v1 ty
393 let s3 = Store v2 vreg
394 return (allStmts `snocOL` s2 `snocOL` s3
395 `appOL` retStmt, top1 ++ top2)
396
397 -- Handle simple function call that only need simple type casting, of the form:
398 -- truncate arg >>= \a -> call(a) >>= zext
399 --
400 -- since GHC only really has i32 and i64 types and things like Word8 are backed
401 -- by an i32 and just present a logical i8 range. So we must handle conversions
402 -- from i32 to i8 explicitly as LLVM is strict about types.
403 genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
404 -> LlvmM StmtData
405 genCallSimpleCast w t@(PrimTarget op) [dst] args = do
406 let width = widthToLlvmInt w
407 dstTy = cmmToLlvmType $ localRegType dst
408
409 fname <- cmmPrimOpFunctions op
410 (fptr, _, top3) <- getInstrinct fname width [width]
411
412 dstV <- getCmmReg (CmmLocal dst)
413
414 let (_, arg_hints) = foreignTargetHints t
415 let args_hints = zip args arg_hints
416 (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, [])
417 (argsV', stmts4) <- castVars $ zip argsV [width]
418 (retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
419 ([retV'], stmts5) <- castVars [(retV,dstTy)]
420 let s2 = Store retV' dstV
421
422 let stmts = stmts2 `appOL` stmts4 `snocOL`
423 s1 `appOL` stmts5 `snocOL` s2
424 return (stmts, top2 ++ top3)
425 genCallSimpleCast _ _ dsts _ =
426 panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts")
427
428 -- | Create a function pointer from a target.
429 getFunPtr :: (LMString -> LlvmType) -> ForeignTarget
430 -> LlvmM ExprData
431 getFunPtr funTy targ = case targ of
432 ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
433 name <- strCLabel_llvm lbl
434 getHsFunc' name (funTy name)
435
436 ForeignTarget expr _ -> do
437 (v1, stmts, top) <- exprToVar expr
438 dflags <- getDynFlags
439 let fty = funTy $ fsLit "dynamic"
440 cast = case getVarType v1 of
441 ty | isPointer ty -> LM_Bitcast
442 ty | isInt ty -> LM_Inttoptr
443
444 ty -> panic $ "genCall: Expr is of bad type for function"
445 ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")"
446
447 (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
448 return (v2, stmts `snocOL` s1, top)
449
450 PrimTarget mop -> do
451 name <- cmmPrimOpFunctions mop
452 let fty = funTy name
453 getInstrinct2 name fty
454
455 -- | Conversion of call arguments.
456 arg_vars :: [(CmmActual, ForeignHint)]
457 -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
458 -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
459
460 arg_vars [] (vars, stmts, tops)
461 = return (vars, stmts, tops)
462
463 arg_vars ((e, AddrHint):rest) (vars, stmts, tops)
464 = do (v1, stmts', top') <- exprToVar e
465 dflags <- getDynFlags
466 let op = case getVarType v1 of
467 ty | isPointer ty -> LM_Bitcast
468 ty | isInt ty -> LM_Inttoptr
469
470 a -> panic $ "genCall: Can't cast llvmType to i8*! ("
471 ++ showSDoc dflags (ppr a) ++ ")"
472
473 (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
474 arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
475 tops ++ top')
476
477 arg_vars ((e, _):rest) (vars, stmts, tops)
478 = do (v1, stmts', top') <- exprToVar e
479 arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
480
481
482 -- | Cast a collection of LLVM variables to specific types.
483 castVars :: [(LlvmVar, LlvmType)]
484 -> LlvmM ([LlvmVar], LlvmStatements)
485 castVars vars = do
486 done <- mapM (uncurry castVar) vars
487 let (vars', stmts) = unzip done
488 return (vars', toOL stmts)
489
490 -- | Cast an LLVM variable to a specific type, panicing if it can't be done.
491 castVar :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
492 castVar v t | getVarType v == t
493 = return (v, Nop)
494
495 | otherwise
496 = do dflags <- getDynFlags
497 let op = case (getVarType v, t) of
498 (LMInt n, LMInt m)
499 -> if n < m then LM_Sext else LM_Trunc
500 (vt, _) | isFloat vt && isFloat t
501 -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t
502 then LM_Fpext else LM_Fptrunc
503 (vt, _) | isInt vt && isFloat t -> LM_Sitofp
504 (vt, _) | isFloat vt && isInt t -> LM_Fptosi
505 (vt, _) | isInt vt && isPointer t -> LM_Inttoptr
506 (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint
507 (vt, _) | isPointer vt && isPointer t -> LM_Bitcast
508 (vt, _) | isVector vt && isVector t -> LM_Bitcast
509
510 (vt, _) -> panic $ "castVars: Can't cast this type ("
511 ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"
512 doExpr t $ Cast op v t
513
514
515 -- | Decide what C function to use to implement a CallishMachOp
516 cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
517 cmmPrimOpFunctions mop = do
518
519 ver <- getLlvmVer
520 dflags <- getDynFlags
521 let intrinTy1 = (if ver >= 28
522 then "p0i8.p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags)
523 intrinTy2 = (if ver >= 28
524 then "p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags)
525 unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
526 ++ " not supported here")
527
528 return $ case mop of
529 MO_F32_Exp -> fsLit "expf"
530 MO_F32_Log -> fsLit "logf"
531 MO_F32_Sqrt -> fsLit "llvm.sqrt.f32"
532 MO_F32_Pwr -> fsLit "llvm.pow.f32"
533
534 MO_F32_Sin -> fsLit "llvm.sin.f32"
535 MO_F32_Cos -> fsLit "llvm.cos.f32"
536 MO_F32_Tan -> fsLit "tanf"
537
538 MO_F32_Asin -> fsLit "asinf"
539 MO_F32_Acos -> fsLit "acosf"
540 MO_F32_Atan -> fsLit "atanf"
541
542 MO_F32_Sinh -> fsLit "sinhf"
543 MO_F32_Cosh -> fsLit "coshf"
544 MO_F32_Tanh -> fsLit "tanhf"
545
546 MO_F64_Exp -> fsLit "exp"
547 MO_F64_Log -> fsLit "log"
548 MO_F64_Sqrt -> fsLit "llvm.sqrt.f64"
549 MO_F64_Pwr -> fsLit "llvm.pow.f64"
550
551 MO_F64_Sin -> fsLit "llvm.sin.f64"
552 MO_F64_Cos -> fsLit "llvm.cos.f64"
553 MO_F64_Tan -> fsLit "tan"
554
555 MO_F64_Asin -> fsLit "asin"
556 MO_F64_Acos -> fsLit "acos"
557 MO_F64_Atan -> fsLit "atan"
558
559 MO_F64_Sinh -> fsLit "sinh"
560 MO_F64_Cosh -> fsLit "cosh"
561 MO_F64_Tanh -> fsLit "tanh"
562
563 MO_Memcpy -> fsLit $ "llvm.memcpy." ++ intrinTy1
564 MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1
565 MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2
566
567 (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
568 (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
569 (MO_Clz w) -> fsLit $ "llvm.ctlz." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
570 (MO_Ctz w) -> fsLit $ "llvm.cttz." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
571
572 (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"
573
574 MO_S_QuotRem {} -> unsupported
575 MO_U_QuotRem {} -> unsupported
576 MO_U_QuotRem2 {} -> unsupported
577 MO_Add2 {} -> unsupported
578 MO_AddIntC {} -> unsupported
579 MO_SubIntC {} -> unsupported
580 MO_U_Mul2 {} -> unsupported
581 MO_WriteBarrier -> unsupported
582 MO_Touch -> unsupported
583 MO_UF_Conv _ -> unsupported
584
585 MO_AtomicRead _ -> unsupported
586
587 MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop
588 MO_Cmpxchg w -> fsLit $ cmpxchgLabel w
589 MO_AtomicWrite w -> fsLit $ atomicWriteLabel w
590
591 -- | Tail function calls
592 genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData
593
594 -- Call to known function
595 genJump (CmmLit (CmmLabel lbl)) live = do
596 (vf, stmts, top) <- getHsFunc live lbl
597 (stgRegs, stgStmts) <- funEpilogue live
598 let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
599 let s2 = Return Nothing
600 return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
601
602
603 -- Call to unknown function / address
604 genJump expr live = do
605 fty <- llvmFunTy live
606 (vf, stmts, top) <- exprToVar expr
607 dflags <- getDynFlags
608
609 let cast = case getVarType vf of
610 ty | isPointer ty -> LM_Bitcast
611 ty | isInt ty -> LM_Inttoptr
612
613 ty -> panic $ "genJump: Expr is of bad type for function call! ("
614 ++ showSDoc dflags (ppr ty) ++ ")"
615
616 (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
617 (stgRegs, stgStmts) <- funEpilogue live
618 let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
619 let s3 = Return Nothing
620 return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
621 top)
622
623
624 -- | CmmAssign operation
625 --
626 -- We use stack allocated variables for CmmReg. The optimiser will replace
627 -- these with registers when possible.
628 genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData
629 genAssign reg val = do
630 vreg <- getCmmReg reg
631 (vval, stmts2, top2) <- exprToVar val
632 let stmts = stmts2
633
634 let ty = (pLower . getVarType) vreg
635 dflags <- getDynFlags
636 case ty of
637 -- Some registers are pointer types, so need to cast value to pointer
638 LMPointer _ | getVarType vval == llvmWord dflags -> do
639 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
640 let s2 = Store v vreg
641 return (stmts `snocOL` s1 `snocOL` s2, top2)
642
643 LMVector _ _ -> do
644 (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty
645 let s2 = Store v vreg
646 return (stmts `snocOL` s1 `snocOL` s2, top2)
647
648 _ -> do
649 let s1 = Store vval vreg
650 return (stmts `snocOL` s1, top2)
651
652
653 -- | CmmStore operation
654 genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData
655
656 -- First we try to detect a few common cases and produce better code for
657 -- these then the default case. We are mostly trying to detect Cmm code
658 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
659 -- generic case that uses casts and pointer arithmetic
660 genStore addr@(CmmReg (CmmGlobal r)) val
661 = genStore_fast addr r 0 val
662
663 genStore addr@(CmmRegOff (CmmGlobal r) n) val
664 = genStore_fast addr r n val
665
666 genStore addr@(CmmMachOp (MO_Add _) [
667 (CmmReg (CmmGlobal r)),
668 (CmmLit (CmmInt n _))])
669 val
670 = genStore_fast addr r (fromInteger n) val
671
672 genStore addr@(CmmMachOp (MO_Sub _) [
673 (CmmReg (CmmGlobal r)),
674 (CmmLit (CmmInt n _))])
675 val
676 = genStore_fast addr r (negate $ fromInteger n) val
677
678 -- generic case
679 genStore addr val
680 = do other <- getTBAAMeta otherN
681 genStore_slow addr val other
682
683 -- | CmmStore operation
684 -- This is a special case for storing to a global register pointer
685 -- offset such as I32[Sp+8].
686 genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr
687 -> LlvmM StmtData
688 genStore_fast addr r n val
689 = do dflags <- getDynFlags
690 (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
691 meta <- getTBAARegMeta r
692 let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
693 case isPointer grt && rem == 0 of
694 True -> do
695 (vval, stmts, top) <- exprToVar val
696 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
697 -- We might need a different pointer type, so check
698 case pLower grt == getVarType vval of
699 -- were fine
700 True -> do
701 let s3 = MetaStmt meta $ Store vval ptr
702 return (stmts `appOL` s1 `snocOL` s2
703 `snocOL` s3, top)
704
705 -- cast to pointer type needed
706 False -> do
707 let ty = (pLift . getVarType) vval
708 (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
709 let s4 = MetaStmt meta $ Store vval ptr'
710 return (stmts `appOL` s1 `snocOL` s2
711 `snocOL` s3 `snocOL` s4, top)
712
713 -- If its a bit type then we use the slow method since
714 -- we can't avoid casting anyway.
715 False -> genStore_slow addr val meta
716
717
718 -- | CmmStore operation
719 -- Generic case. Uses casts and pointer arithmetic if needed.
720 genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData
721 genStore_slow addr val meta = do
722 (vaddr, stmts1, top1) <- exprToVar addr
723 (vval, stmts2, top2) <- exprToVar val
724
725 let stmts = stmts1 `appOL` stmts2
726 dflags <- getDynFlags
727 case getVarType vaddr of
728 -- sometimes we need to cast an int to a pointer before storing
729 LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do
730 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
731 let s2 = MetaStmt meta $ Store v vaddr
732 return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
733
734 LMPointer _ -> do
735 let s1 = MetaStmt meta $ Store vval vaddr
736 return (stmts `snocOL` s1, top1 ++ top2)
737
738 i@(LMInt _) | i == llvmWord dflags -> do
739 let vty = pLift $ getVarType vval
740 (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
741 let s2 = MetaStmt meta $ Store vval vptr
742 return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
743
744 other ->
745 pprPanic "genStore: ptr not right type!"
746 (PprCmm.pprExpr addr <+> text (
747 "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
748 ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
749 ", Var: " ++ showSDoc dflags (ppr vaddr)))
750
751
752 -- | Unconditional branch
753 genBranch :: BlockId -> LlvmM StmtData
754 genBranch id =
755 let label = blockIdToLlvm id
756 in return (unitOL $ Branch label, [])
757
758
759 -- | Conditional branch
760 genCondBranch :: CmmExpr -> BlockId -> BlockId -> LlvmM StmtData
761 genCondBranch cond idT idF = do
762 let labelT = blockIdToLlvm idT
763 let labelF = blockIdToLlvm idF
764 -- See Note [Literals and branch conditions].
765 (vc, stmts, top) <- exprToVarOpt i1Option cond
766 if getVarType vc == i1
767 then do
768 let s1 = BranchIf vc labelT labelF
769 return (stmts `snocOL` s1, top)
770 else do
771 dflags <- getDynFlags
772 panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"
773
774 {- Note [Literals and branch conditions]
775 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
776
777 It is important that whenever we generate branch conditions for
778 literals like '1', they are properly narrowed to an LLVM expression of
779 type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
780 a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
781 must be certain to return a properly narrowed type. genLit is
782 responsible for this, in the case of literal integers.
783
784 Often, we won't see direct statements like:
785
786 if(1) {
787 ...
788 } else {
789 ...
790 }
791
792 at this point in the pipeline, because the Glorious Code Generator
793 will do trivial branch elimination in the sinking pass (among others,)
794 which will eliminate the expression entirely.
795
796 However, it's certainly possible and reasonable for this to occur in
797 hand-written C-- code. Consider something like:
798
799 #ifndef SOME_CONDITIONAL
800 #define CHECK_THING(x) 1
801 #else
802 #define CHECK_THING(x) some_operation((x))
803 #endif
804
805 f() {
806
807 if (CHECK_THING(xyz)) {
808 ...
809 } else {
810 ...
811 }
812
813 }
814
815 In such an instance, CHECK_THING might result in an *expression* in
816 one case, and a *literal* in the other, depending on what in
817 particular was #define'd. So we must be sure to properly narrow the
818 literal in this case to i1 as it won't be eliminated beforehand.
819
820 For a real example of this, see ./rts/StgStdThunks.cmm
821
822 -}
823
824
825
826 -- | Switch branch
827 genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData
828 genSwitch cond ids = do
829 (vc, stmts, top) <- exprToVar cond
830 let ty = getVarType vc
831
832 let labels = [ (mkIntLit ty ix, blockIdToLlvm b)
833 | (ix, b) <- switchTargetsCases ids ]
834 -- out of range is undefined, so let's just branch to first label
835 let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l
836 | otherwise = snd (head labels)
837
838 let s1 = Switch vc defLbl labels
839 return $ (stmts `snocOL` s1, top)
840
841
842 -- -----------------------------------------------------------------------------
843 -- * CmmExpr code generation
844 --
845
846 -- | An expression conversion return data:
847 -- * LlvmVar: The var holding the result of the expression
848 -- * LlvmStatements: Any statements needed to evaluate the expression
849 -- * LlvmCmmDecl: Any global data needed for this expression
850 type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])
851
852 -- | Values which can be passed to 'exprToVar' to configure its
853 -- behaviour in certain circumstances.
854 --
855 -- Currently just used for determining if a comparison should return
856 -- a boolean (i1) or a word. See Note [Literals and branch conditions].
857 newtype EOption = EOption { i1Expected :: Bool }
858 -- XXX: EOption is an ugly and inefficient solution to this problem.
859
860 -- | i1 type expected (condition scrutinee).
861 i1Option :: EOption
862 i1Option = EOption True
863
864 -- | Word type expected (usual).
865 wordOption :: EOption
866 wordOption = EOption False
867
868 -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
869 -- expression being stored in the returned LlvmVar.
870 exprToVar :: CmmExpr -> LlvmM ExprData
871 exprToVar = exprToVarOpt wordOption
872
873 exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData
874 exprToVarOpt opt e = case e of
875
876 CmmLit lit
877 -> genLit opt lit
878
879 CmmLoad e' ty
880 -> genLoad False e' ty
881
882 -- Cmmreg in expression is the value, so must load. If you want actual
883 -- reg pointer, call getCmmReg directly.
884 CmmReg r -> do
885 (v1, ty, s1) <- getCmmRegVal r
886 case isPointer ty of
887 True -> do
888 -- Cmm wants the value, so pointer types must be cast to ints
889 dflags <- getDynFlags
890 (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)
891 return (v2, s1 `snocOL` s2, [])
892
893 False -> return (v1, s1, [])
894
895 CmmMachOp op exprs
896 -> genMachOp opt op exprs
897
898 CmmRegOff r i
899 -> do dflags <- getDynFlags
900 exprToVar $ expandCmmReg dflags (r, i)
901
902 CmmStackSlot _ _
903 -> panic "exprToVar: CmmStackSlot not supported!"
904
905
906 -- | Handle CmmMachOp expressions
907 genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
908
909 -- Unary Machop
910 genMachOp _ op [x] = case op of
911
912 MO_Not w ->
913 let all1 = mkIntLit (widthToLlvmInt w) (-1)
914 in negate (widthToLlvmInt w) all1 LM_MO_Xor
915
916 MO_S_Neg w ->
917 let all0 = mkIntLit (widthToLlvmInt w) 0
918 in negate (widthToLlvmInt w) all0 LM_MO_Sub
919
920 MO_F_Neg w ->
921 let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
922 in negate (widthToLlvmFloat w) all0 LM_MO_FSub
923
924 MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
925 MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
926
927 MO_SS_Conv from to
928 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
929
930 MO_UU_Conv from to
931 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
932
933 MO_FF_Conv from to
934 -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
935
936 MO_VS_Neg len w ->
937 let ty = widthToLlvmInt w
938 vecty = LMVector len ty
939 all0 = LMIntLit (-0) ty
940 all0s = LMLitVar $ LMVectorLit (replicate len all0)
941 in negateVec vecty all0s LM_MO_Sub
942
943 MO_VF_Neg len w ->
944 let ty = widthToLlvmFloat w
945 vecty = LMVector len ty
946 all0 = LMFloatLit (-0) ty
947 all0s = LMLitVar $ LMVectorLit (replicate len all0)
948 in negateVec vecty all0s LM_MO_FSub
949
950 -- Handle unsupported cases explicitly so we get a warning
951 -- of missing case when new MachOps added
952 MO_Add _ -> panicOp
953 MO_Mul _ -> panicOp
954 MO_Sub _ -> panicOp
955 MO_S_MulMayOflo _ -> panicOp
956 MO_S_Quot _ -> panicOp
957 MO_S_Rem _ -> panicOp
958 MO_U_MulMayOflo _ -> panicOp
959 MO_U_Quot _ -> panicOp
960 MO_U_Rem _ -> panicOp
961
962 MO_Eq _ -> panicOp
963 MO_Ne _ -> panicOp
964 MO_S_Ge _ -> panicOp
965 MO_S_Gt _ -> panicOp
966 MO_S_Le _ -> panicOp
967 MO_S_Lt _ -> panicOp
968 MO_U_Ge _ -> panicOp
969 MO_U_Gt _ -> panicOp
970 MO_U_Le _ -> panicOp
971 MO_U_Lt _ -> panicOp
972
973 MO_F_Add _ -> panicOp
974 MO_F_Sub _ -> panicOp
975 MO_F_Mul _ -> panicOp
976 MO_F_Quot _ -> panicOp
977 MO_F_Eq _ -> panicOp
978 MO_F_Ne _ -> panicOp
979 MO_F_Ge _ -> panicOp
980 MO_F_Gt _ -> panicOp
981 MO_F_Le _ -> panicOp
982 MO_F_Lt _ -> panicOp
983
984 MO_And _ -> panicOp
985 MO_Or _ -> panicOp
986 MO_Xor _ -> panicOp
987 MO_Shl _ -> panicOp
988 MO_U_Shr _ -> panicOp
989 MO_S_Shr _ -> panicOp
990
991 MO_V_Insert _ _ -> panicOp
992 MO_V_Extract _ _ -> panicOp
993
994 MO_V_Add _ _ -> panicOp
995 MO_V_Sub _ _ -> panicOp
996 MO_V_Mul _ _ -> panicOp
997
998 MO_VS_Quot _ _ -> panicOp
999 MO_VS_Rem _ _ -> panicOp
1000
1001 MO_VU_Quot _ _ -> panicOp
1002 MO_VU_Rem _ _ -> panicOp
1003
1004 MO_VF_Insert _ _ -> panicOp
1005 MO_VF_Extract _ _ -> panicOp
1006
1007 MO_VF_Add _ _ -> panicOp
1008 MO_VF_Sub _ _ -> panicOp
1009 MO_VF_Mul _ _ -> panicOp
1010 MO_VF_Quot _ _ -> panicOp
1011
1012 where
1013 negate ty v2 negOp = do
1014 (vx, stmts, top) <- exprToVar x
1015 (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
1016 return (v1, stmts `snocOL` s1, top)
1017
1018 negateVec ty v2 negOp = do
1019 (vx, stmts1, top) <- exprToVar x
1020 ([vx'], stmts2) <- castVars [(vx, ty)]
1021 (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
1022 return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
1023
1024 fiConv ty convOp = do
1025 (vx, stmts, top) <- exprToVar x
1026 (v1, s1) <- doExpr ty $ Cast convOp vx ty
1027 return (v1, stmts `snocOL` s1, top)
1028
1029 sameConv from ty reduce expand = do
1030 x'@(vx, stmts, top) <- exprToVar x
1031 let sameConv' op = do
1032 (v1, s1) <- doExpr ty $ Cast op vx ty
1033 return (v1, stmts `snocOL` s1, top)
1034 dflags <- getDynFlags
1035 let toWidth = llvmWidthInBits dflags ty
1036 -- LLVM doesn't like trying to convert to same width, so
1037 -- need to check for that as we do get Cmm code doing it.
1038 case widthInBits from of
1039 w | w < toWidth -> sameConv' expand
1040 w | w > toWidth -> sameConv' reduce
1041 _w -> return x'
1042
1043 panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered"
1044 ++ "with one argument! (" ++ show op ++ ")"
1045
1046 -- Handle GlobalRegs pointers
1047 genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
1048 = genMachOp_fast opt o r (fromInteger n) e
1049
1050 genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
1051 = genMachOp_fast opt o r (negate . fromInteger $ n) e
1052
1053 -- Generic case
1054 genMachOp opt op e = genMachOp_slow opt op e
1055
1056
1057 -- | Handle CmmMachOp expressions
1058 -- This is a specialised method that handles Global register manipulations like
1059 -- 'Sp - 16', using the getelementptr instruction.
1060 genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
1061 -> LlvmM ExprData
1062 genMachOp_fast opt op r n e
1063 = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
1064 dflags <- getDynFlags
1065 let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
1066 case isPointer grt && rem == 0 of
1067 True -> do
1068 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
1069 (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)
1070 return (var, s1 `snocOL` s2 `snocOL` s3, [])
1071
1072 False -> genMachOp_slow opt op e
1073
1074
1075 -- | Handle CmmMachOp expressions
1076 -- This handles all the cases not handle by the specialised genMachOp_fast.
1077 genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
1078
1079 -- Element extraction
1080 genMachOp_slow _ (MO_V_Extract l w) [val, idx] = do
1081 (vval, stmts1, top1) <- exprToVar val
1082 (vidx, stmts2, top2) <- exprToVar idx
1083 ([vval'], stmts3) <- castVars [(vval, LMVector l ty)]
1084 (v1, s1) <- doExpr ty $ Extract vval' vidx
1085 return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2)
1086 where
1087 ty = widthToLlvmInt w
1088
1089 genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = do
1090 (vval, stmts1, top1) <- exprToVar val
1091 (vidx, stmts2, top2) <- exprToVar idx
1092 ([vval'], stmts3) <- castVars [(vval, LMVector l ty)]
1093 (v1, s1) <- doExpr ty $ Extract vval' vidx
1094 return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2)
1095 where
1096 ty = widthToLlvmFloat w
1097
1098 -- Element insertion
1099 genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = do
1100 (vval, stmts1, top1) <- exprToVar val
1101 (velt, stmts2, top2) <- exprToVar elt
1102 (vidx, stmts3, top3) <- exprToVar idx
1103 ([vval'], stmts4) <- castVars [(vval, ty)]
1104 (v1, s1) <- doExpr ty $ Insert vval' velt vidx
1105 return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1,
1106 top1 ++ top2 ++ top3)
1107 where
1108 ty = LMVector l (widthToLlvmInt w)
1109
1110 genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = do
1111 (vval, stmts1, top1) <- exprToVar val
1112 (velt, stmts2, top2) <- exprToVar elt
1113 (vidx, stmts3, top3) <- exprToVar idx
1114 ([vval'], stmts4) <- castVars [(vval, ty)]
1115 (v1, s1) <- doExpr ty $ Insert vval' velt vidx
1116 return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1,
1117 top1 ++ top2 ++ top3)
1118 where
1119 ty = LMVector l (widthToLlvmFloat w)
1120
1121 -- Binary MachOp
1122 genMachOp_slow opt op [x, y] = case op of
1123
1124 MO_Eq _ -> genBinComp opt LM_CMP_Eq
1125 MO_Ne _ -> genBinComp opt LM_CMP_Ne
1126
1127 MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
1128 MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
1129 MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
1130 MO_S_Le _ -> genBinComp opt LM_CMP_Sle
1131
1132 MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
1133 MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
1134 MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
1135 MO_U_Le _ -> genBinComp opt LM_CMP_Ule
1136
1137 MO_Add _ -> genBinMach LM_MO_Add
1138 MO_Sub _ -> genBinMach LM_MO_Sub
1139 MO_Mul _ -> genBinMach LM_MO_Mul
1140
1141 MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
1142
1143 MO_S_MulMayOflo w -> isSMulOK w x y
1144
1145 MO_S_Quot _ -> genBinMach LM_MO_SDiv
1146 MO_S_Rem _ -> genBinMach LM_MO_SRem
1147
1148 MO_U_Quot _ -> genBinMach LM_MO_UDiv
1149 MO_U_Rem _ -> genBinMach LM_MO_URem
1150
1151 MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
1152 MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
1153 MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
1154 MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
1155 MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
1156 MO_F_Le _ -> genBinComp opt LM_CMP_Fle
1157
1158 MO_F_Add _ -> genBinMach LM_MO_FAdd
1159 MO_F_Sub _ -> genBinMach LM_MO_FSub
1160 MO_F_Mul _ -> genBinMach LM_MO_FMul
1161 MO_F_Quot _ -> genBinMach LM_MO_FDiv
1162
1163 MO_And _ -> genBinMach LM_MO_And
1164 MO_Or _ -> genBinMach LM_MO_Or
1165 MO_Xor _ -> genBinMach LM_MO_Xor
1166 MO_Shl _ -> genBinMach LM_MO_Shl
1167 MO_U_Shr _ -> genBinMach LM_MO_LShr
1168 MO_S_Shr _ -> genBinMach LM_MO_AShr
1169
1170 MO_V_Add l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add
1171 MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub
1172 MO_V_Mul l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul
1173
1174 MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv
1175 MO_VS_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem
1176
1177 MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv
1178 MO_VU_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem
1179
1180 MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd
1181 MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub
1182 MO_VF_Mul l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul
1183 MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv
1184
1185 MO_Not _ -> panicOp
1186 MO_S_Neg _ -> panicOp
1187 MO_F_Neg _ -> panicOp
1188
1189 MO_SF_Conv _ _ -> panicOp
1190 MO_FS_Conv _ _ -> panicOp
1191 MO_SS_Conv _ _ -> panicOp
1192 MO_UU_Conv _ _ -> panicOp
1193 MO_FF_Conv _ _ -> panicOp
1194
1195 MO_V_Insert {} -> panicOp
1196 MO_V_Extract {} -> panicOp
1197
1198 MO_VS_Neg {} -> panicOp
1199
1200 MO_VF_Insert {} -> panicOp
1201 MO_VF_Extract {} -> panicOp
1202
1203 MO_VF_Neg {} -> panicOp
1204
1205 where
1206 binLlvmOp ty binOp = do
1207 (vx, stmts1, top1) <- exprToVar x
1208 (vy, stmts2, top2) <- exprToVar y
1209 if getVarType vx == getVarType vy
1210 then do
1211 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
1212 return (v1, stmts1 `appOL` stmts2 `snocOL` s1,
1213 top1 ++ top2)
1214
1215 else do
1216 -- Error. Continue anyway so we can debug the generated ll file.
1217 dflags <- getDynFlags
1218 let style = mkCodeStyle CStyle
1219 toString doc = renderWithStyle dflags doc style
1220 cmmToStr = (lines . toString . PprCmm.pprExpr)
1221 let dx = Comment $ map fsLit $ cmmToStr x
1222 let dy = Comment $ map fsLit $ cmmToStr y
1223 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
1224 let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
1225 `snocOL` dy `snocOL` s1
1226 return (v1, allStmts, top1 ++ top2)
1227
1228 binCastLlvmOp ty binOp = do
1229 (vx, stmts1, top1) <- exprToVar x
1230 (vy, stmts2, top2) <- exprToVar y
1231 ([vx', vy'], stmts3) <- castVars [(vx, ty), (vy, ty)]
1232 (v1, s1) <- doExpr ty $ binOp vx' vy'
1233 return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1,
1234 top1 ++ top2)
1235
1236 -- | Need to use EOption here as Cmm expects word size results from
1237 -- comparisons while LLVM return i1. Need to extend to llvmWord type
1238 -- if expected. See Note [Literals and branch conditions].
1239 genBinComp opt cmp = do
1240 ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
1241 dflags <- getDynFlags
1242 if getVarType v1 == i1
1243 then case i1Expected opt of
1244 True -> return ed
1245 False -> do
1246 let w_ = llvmWord dflags
1247 (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
1248 return (v2, stmts `snocOL` s1, top)
1249 else
1250 panic $ "genBinComp: Compare returned type other then i1! "
1251 ++ (showSDoc dflags $ ppr $ getVarType v1)
1252
1253 genBinMach op = binLlvmOp getVarType (LlvmOp op)
1254
1255 genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)
1256
1257 -- | Detect if overflow will occur in signed multiply of the two
1258 -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
1259 -- implementation. Its much longer due to type information/safety.
1260 -- This should actually compile to only about 3 asm instructions.
1261 isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
1262 isSMulOK _ x y = do
1263 (vx, stmts1, top1) <- exprToVar x
1264 (vy, stmts2, top2) <- exprToVar y
1265
1266 dflags <- getDynFlags
1267 let word = getVarType vx
1268 let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
1269 let shift = llvmWidthInBits dflags word
1270 let shift1 = toIWord dflags (shift - 1)
1271 let shift2 = toIWord dflags shift
1272
1273 if isInt word
1274 then do
1275 (x1, s1) <- doExpr word2 $ Cast LM_Sext vx word2
1276 (y1, s2) <- doExpr word2 $ Cast LM_Sext vy word2
1277 (r1, s3) <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
1278 (rlow1, s4) <- doExpr word $ Cast LM_Trunc r1 word
1279 (rlow2, s5) <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
1280 (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
1281 (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
1282 (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
1283 let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
1284 `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
1285 return (dst, stmts1 `appOL` stmts2 `appOL` stmts,
1286 top1 ++ top2)
1287
1288 else
1289 panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"
1290
1291 panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"
1292 ++ "with two arguments! (" ++ show op ++ ")"
1293
1294 -- More then two expression, invalid!
1295 genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
1296
1297
1298 -- | Handle CmmLoad expression.
1299 genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData
1300
1301 -- First we try to detect a few common cases and produce better code for
1302 -- these then the default case. We are mostly trying to detect Cmm code
1303 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
1304 -- generic case that uses casts and pointer arithmetic
1305 genLoad atomic e@(CmmReg (CmmGlobal r)) ty
1306 = genLoad_fast atomic e r 0 ty
1307
1308 genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty
1309 = genLoad_fast atomic e r n ty
1310
1311 genLoad atomic e@(CmmMachOp (MO_Add _) [
1312 (CmmReg (CmmGlobal r)),
1313 (CmmLit (CmmInt n _))])
1314 ty
1315 = genLoad_fast atomic e r (fromInteger n) ty
1316
1317 genLoad atomic e@(CmmMachOp (MO_Sub _) [
1318 (CmmReg (CmmGlobal r)),
1319 (CmmLit (CmmInt n _))])
1320 ty
1321 = genLoad_fast atomic e r (negate $ fromInteger n) ty
1322
1323 -- generic case
1324 genLoad atomic e ty
1325 = do other <- getTBAAMeta otherN
1326 genLoad_slow atomic e ty other
1327
1328 -- | Handle CmmLoad expression.
1329 -- This is a special case for loading from a global register pointer
1330 -- offset such as I32[Sp+8].
1331 genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType
1332 -> LlvmM ExprData
1333 genLoad_fast atomic e r n ty = do
1334 dflags <- getDynFlags
1335 (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
1336 meta <- getTBAARegMeta r
1337 let ty' = cmmToLlvmType ty
1338 (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
1339 case isPointer grt && rem == 0 of
1340 True -> do
1341 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
1342 -- We might need a different pointer type, so check
1343 case grt == ty' of
1344 -- were fine
1345 True -> do
1346 (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr)
1347 return (var, s1 `snocOL` s2 `snocOL` s3,
1348 [])
1349
1350 -- cast to pointer type needed
1351 False -> do
1352 let pty = pLift ty'
1353 (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
1354 (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr')
1355 return (var, s1 `snocOL` s2 `snocOL` s3
1356 `snocOL` s4, [])
1357
1358 -- If its a bit type then we use the slow method since
1359 -- we can't avoid casting anyway.
1360 False -> genLoad_slow atomic e ty meta
1361 where
1362 loadInstr ptr | atomic = ALoad SyncSeqCst False ptr
1363 | otherwise = Load ptr
1364
1365 -- | Handle Cmm load expression.
1366 -- Generic case. Uses casts and pointer arithmetic if needed.
1367 genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
1368 genLoad_slow atomic e ty meta = do
1369 (iptr, stmts, tops) <- exprToVar e
1370 dflags <- getDynFlags
1371 case getVarType iptr of
1372 LMPointer _ -> do
1373 (dvar, load) <- doExpr (cmmToLlvmType ty)
1374 (MExpr meta $ loadInstr iptr)
1375 return (dvar, stmts `snocOL` load, tops)
1376
1377 i@(LMInt _) | i == llvmWord dflags -> do
1378 let pty = LMPointer $ cmmToLlvmType ty
1379 (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty
1380 (dvar, load) <- doExpr (cmmToLlvmType ty)
1381 (MExpr meta $ loadInstr ptr)
1382 return (dvar, stmts `snocOL` cast `snocOL` load, tops)
1383
1384 other -> do dflags <- getDynFlags
1385 pprPanic "exprToVar: CmmLoad expression is not right type!"
1386 (PprCmm.pprExpr e <+> text (
1387 "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
1388 ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
1389 ", Var: " ++ showSDoc dflags (ppr iptr)))
1390 where
1391 loadInstr ptr | atomic = ALoad SyncSeqCst False ptr
1392 | otherwise = Load ptr
1393
1394
1395 -- | Handle CmmReg expression. This will return a pointer to the stack
1396 -- location of the register. Throws an error if it isn't allocated on
1397 -- the stack.
1398 getCmmReg :: CmmReg -> LlvmM LlvmVar
1399 getCmmReg (CmmLocal (LocalReg un _))
1400 = do exists <- varLookup un
1401 dflags <- getDynFlags
1402 case exists of
1403 Just ety -> return (LMLocalVar un $ pLift ety)
1404 Nothing -> fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"
1405 -- This should never happen, as every local variable should
1406 -- have been assigned a value at some point, triggering
1407 -- "funPrologue" to allocate it on the stack.
1408
1409 getCmmReg (CmmGlobal g)
1410 = do onStack <- checkStackReg g
1411 dflags <- getDynFlags
1412 if onStack
1413 then return (lmGlobalRegVar dflags g)
1414 else fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"
1415
1416 -- | Return the value of a given register, as well as its type. Might
1417 -- need to be load from stack.
1418 getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
1419 getCmmRegVal reg =
1420 case reg of
1421 CmmGlobal g -> do
1422 onStack <- checkStackReg g
1423 dflags <- getDynFlags
1424 if onStack then loadFromStack else do
1425 let r = lmGlobalRegArg dflags g
1426 return (r, getVarType r, nilOL)
1427 _ -> loadFromStack
1428 where loadFromStack = do
1429 ptr <- getCmmReg reg
1430 let ty = pLower $ getVarType ptr
1431 (v, s) <- doExpr ty (Load ptr)
1432 return (v, ty, unitOL s)
1433
1434 -- | Allocate a local CmmReg on the stack
1435 allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
1436 allocReg (CmmLocal (LocalReg un ty))
1437 = let ty' = cmmToLlvmType ty
1438 var = LMLocalVar un (LMPointer ty')
1439 alc = Alloca ty' 1
1440 in (var, unitOL $ Assignment var alc)
1441
1442 allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
1443 ++ " have been handled elsewhere!"
1444
1445
1446 -- | Generate code for a literal
1447 genLit :: EOption -> CmmLit -> LlvmM ExprData
1448 genLit opt (CmmInt i w)
1449 -- See Note [Literals and branch conditions].
1450 = let width | i1Expected opt = i1
1451 | otherwise = LMInt (widthInBits w)
1452 -- comm = Comment [ fsLit $ "EOption: " ++ show opt
1453 -- , fsLit $ "Width : " ++ show w
1454 -- , fsLit $ "Width' : " ++ show (widthInBits w)
1455 -- ]
1456 in return (mkIntLit width i, nilOL, [])
1457
1458 genLit _ (CmmFloat r w)
1459 = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
1460 nilOL, [])
1461
1462 genLit opt (CmmVec ls)
1463 = do llvmLits <- mapM toLlvmLit ls
1464 return (LMLitVar $ LMVectorLit llvmLits, nilOL, [])
1465 where
1466 toLlvmLit :: CmmLit -> LlvmM LlvmLit
1467 toLlvmLit lit = do
1468 (llvmLitVar, _, _) <- genLit opt lit
1469 case llvmLitVar of
1470 LMLitVar llvmLit -> return llvmLit
1471 _ -> panic "genLit"
1472
1473 genLit _ cmm@(CmmLabel l)
1474 = do var <- getGlobalPtr =<< strCLabel_llvm l
1475 dflags <- getDynFlags
1476 let lmty = cmmToLlvmType $ cmmLitType dflags cmm
1477 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
1478 return (v1, unitOL s1, [])
1479
1480 genLit opt (CmmLabelOff label off) = do
1481 dflags <- getDynFlags
1482 (vlbl, stmts, stat) <- genLit opt (CmmLabel label)
1483 let voff = toIWord dflags off
1484 (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
1485 return (v1, stmts `snocOL` s1, stat)
1486
1487 genLit opt (CmmLabelDiffOff l1 l2 off) = do
1488 dflags <- getDynFlags
1489 (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)
1490 (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)
1491 let voff = toIWord dflags off
1492 let ty1 = getVarType vl1
1493 let ty2 = getVarType vl2
1494 if (isInt ty1) && (isInt ty2)
1495 && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)
1496
1497 then do
1498 (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
1499 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
1500 return (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
1501 stat1 ++ stat2)
1502
1503 else
1504 panic "genLit: CmmLabelDiffOff encountered with different label ty!"
1505
1506 genLit opt (CmmBlock b)
1507 = genLit opt (CmmLabel $ infoTblLbl b)
1508
1509 genLit _ CmmHighStackMark
1510 = panic "genStaticLit - CmmHighStackMark unsupported!"
1511
1512
1513 -- -----------------------------------------------------------------------------
1514 -- * Misc
1515 --
1516
1517 -- | Find CmmRegs that get assigned and allocate them on the stack
1518 --
1519 -- Any register that gets written needs to be allcoated on the
1520 -- stack. This avoids having to map a CmmReg to an equivalent SSA form
1521 -- and avoids having to deal with Phi node insertion. This is also
1522 -- the approach recommended by LLVM developers.
1523 --
1524 -- On the other hand, this is unecessarily verbose if the register in
1525 -- question is never written. Therefore we skip it where we can to
1526 -- save a few lines in the output and hopefully speed compilation up a
1527 -- bit.
1528 funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData
1529 funPrologue live cmmBlocks = do
1530
1531 trash <- getTrashRegs
1532 let getAssignedRegs :: CmmNode O O -> [CmmReg]
1533 getAssignedRegs (CmmAssign reg _) = [reg]
1534 -- Calls will trash all registers. Unfortunately, this needs them to
1535 -- be stack-allocated in the first place.
1536 getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs
1537 getAssignedRegs _ = []
1538 getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body
1539 assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks
1540 isLive r = r `elem` alwaysLive || r `elem` live
1541
1542 dflags <- getDynFlags
1543 stmtss <- flip mapM assignedRegs $ \reg ->
1544 case reg of
1545 CmmLocal (LocalReg un _) -> do
1546 let (newv, stmts) = allocReg reg
1547 varInsert un (pLower $ getVarType newv)
1548 return stmts
1549 CmmGlobal r -> do
1550 let reg = lmGlobalRegVar dflags r
1551 arg = lmGlobalRegArg dflags r
1552 ty = (pLower . getVarType) reg
1553 trash = LMLitVar $ LMUndefLit ty
1554 rval = if isLive r then arg else trash
1555 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
1556 markStackReg r
1557 return $ toOL [alloc, Store rval reg]
1558
1559 return (concatOL stmtss, [])
1560
1561 -- | Function epilogue. Load STG variables to use as argument for call.
1562 -- STG Liveness optimisation done here.
1563 funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
1564 funEpilogue live = do
1565
1566 -- Have information and liveness optimisation is enabled?
1567 let liveRegs = alwaysLive ++ live
1568 isSSE (FloatReg _) = True
1569 isSSE (DoubleReg _) = True
1570 isSSE (XmmReg _) = True
1571 isSSE (YmmReg _) = True
1572 isSSE (ZmmReg _) = True
1573 isSSE _ = False
1574
1575 -- Set to value or "undef" depending on whether the register is
1576 -- actually live
1577 dflags <- getDynFlags
1578 let loadExpr r = do
1579 (v, _, s) <- getCmmRegVal (CmmGlobal r)
1580 return (Just $ v, s)
1581 loadUndef r = do
1582 let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
1583 return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
1584 platform <- getDynFlag targetPlatform
1585 loads <- flip mapM (activeStgRegs platform) $ \r -> case () of
1586 _ | r `elem` liveRegs -> loadExpr r
1587 | not (isSSE r) -> loadUndef r
1588 | otherwise -> return (Nothing, nilOL)
1589
1590 let (vars, stmts) = unzip loads
1591 return (catMaybes vars, concatOL stmts)
1592
1593
1594 -- | A series of statements to trash all the STG registers.
1595 --
1596 -- In LLVM we pass the STG registers around everywhere in function calls.
1597 -- So this means LLVM considers them live across the entire function, when
1598 -- in reality they usually aren't. For Caller save registers across C calls
1599 -- the saving and restoring of them is done by the Cmm code generator,
1600 -- using Cmm local vars. So to stop LLVM saving them as well (and saving
1601 -- all of them since it thinks they're always live, we trash them just
1602 -- before the call by assigning the 'undef' value to them. The ones we
1603 -- need are restored from the Cmm local var and the ones we don't need
1604 -- are fine to be trashed.
1605 getTrashStmts :: LlvmM LlvmStatements
1606 getTrashStmts = do
1607 regs <- getTrashRegs
1608 stmts <- flip mapM regs $ \ r -> do
1609 reg <- getCmmReg (CmmGlobal r)
1610 let ty = (pLower . getVarType) reg
1611 return $ Store (LMLitVar $ LMUndefLit ty) reg
1612 return $ toOL stmts
1613
1614 getTrashRegs :: LlvmM [GlobalReg]
1615 getTrashRegs = do plat <- getLlvmPlatform
1616 return $ filter (callerSaves plat) (activeStgRegs plat)
1617
1618 -- | Get a function pointer to the CLabel specified.
1619 --
1620 -- This is for Haskell functions, function type is assumed, so doesn't work
1621 -- with foreign functions.
1622 getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData
1623 getHsFunc live lbl
1624 = do fty <- llvmFunTy live
1625 name <- strCLabel_llvm lbl
1626 getHsFunc' name fty
1627
1628 getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData
1629 getHsFunc' name fty
1630 = do fun <- getGlobalPtr name
1631 if getVarType fun == fty
1632 then return (fun, nilOL, [])
1633 else do (v1, s1) <- doExpr (pLift fty)
1634 $ Cast LM_Bitcast fun (pLift fty)
1635 return (v1, unitOL s1, [])
1636
1637 -- | Create a new local var
1638 mkLocalVar :: LlvmType -> LlvmM LlvmVar
1639 mkLocalVar ty = do
1640 un <- runUs getUniqueM
1641 return $ LMLocalVar un ty
1642
1643
1644 -- | Execute an expression, assigning result to a var
1645 doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
1646 doExpr ty expr = do
1647 v <- mkLocalVar ty
1648 return (v, Assignment v expr)
1649
1650
1651 -- | Expand CmmRegOff
1652 expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr
1653 expandCmmReg dflags (reg, off)
1654 = let width = typeWidth (cmmRegType dflags reg)
1655 voff = CmmLit $ CmmInt (fromIntegral off) width
1656 in CmmMachOp (MO_Add width) [CmmReg reg, voff]
1657
1658
1659 -- | Convert a block id into a appropriate Llvm label
1660 blockIdToLlvm :: BlockId -> LlvmVar
1661 blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
1662
1663 -- | Create Llvm int Literal
1664 mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
1665 mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
1666
1667 -- | Convert int type to a LLvmVar of word or i32 size
1668 toI32 :: Integral a => a -> LlvmVar
1669 toI32 = mkIntLit i32
1670
1671 toIWord :: Integral a => DynFlags -> a -> LlvmVar
1672 toIWord dflags = mkIntLit (llvmWord dflags)
1673
1674
1675 -- | Returns TBAA meta data by unique
1676 getTBAAMeta :: Unique -> LlvmM [MetaAnnot]
1677 getTBAAMeta u = do
1678 mi <- getUniqMeta u
1679 return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]
1680
1681 -- | Returns TBAA meta data for given register
1682 getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]
1683 getTBAARegMeta = getTBAAMeta . getTBAA