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