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