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