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