Implement function-sections for Haskell code, #8405
[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 MIN_VERSION_base(4,8,0)
38 #else
39 import Data.Monoid ( Monoid, mappend, mempty )
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 exepected 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 _ -- TODO: likely annotation
122 -> genCondBranch arg true false
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 <- runUs 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 <- lift $ 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 <- lift $ 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_Pwr -> fsLit "llvm.pow.f32"
694
695 MO_F32_Sin -> fsLit "llvm.sin.f32"
696 MO_F32_Cos -> fsLit "llvm.cos.f32"
697 MO_F32_Tan -> fsLit "tanf"
698
699 MO_F32_Asin -> fsLit "asinf"
700 MO_F32_Acos -> fsLit "acosf"
701 MO_F32_Atan -> fsLit "atanf"
702
703 MO_F32_Sinh -> fsLit "sinhf"
704 MO_F32_Cosh -> fsLit "coshf"
705 MO_F32_Tanh -> fsLit "tanhf"
706
707 MO_F64_Exp -> fsLit "exp"
708 MO_F64_Log -> fsLit "log"
709 MO_F64_Sqrt -> fsLit "llvm.sqrt.f64"
710 MO_F64_Pwr -> fsLit "llvm.pow.f64"
711
712 MO_F64_Sin -> fsLit "llvm.sin.f64"
713 MO_F64_Cos -> fsLit "llvm.cos.f64"
714 MO_F64_Tan -> fsLit "tan"
715
716 MO_F64_Asin -> fsLit "asin"
717 MO_F64_Acos -> fsLit "acos"
718 MO_F64_Atan -> fsLit "atan"
719
720 MO_F64_Sinh -> fsLit "sinh"
721 MO_F64_Cosh -> fsLit "cosh"
722 MO_F64_Tanh -> fsLit "tanh"
723
724 MO_Memcpy _ -> fsLit $ "llvm.memcpy." ++ intrinTy1
725 MO_Memmove _ -> fsLit $ "llvm.memmove." ++ intrinTy1
726 MO_Memset _ -> fsLit $ "llvm.memset." ++ intrinTy2
727
728 (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
729 (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
730 (MO_Clz w) -> fsLit $ "llvm.ctlz." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
731 (MO_Ctz w) -> fsLit $ "llvm.cttz." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
732
733 (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"
734
735 MO_AddIntC w -> fsLit $ "llvm.sadd.with.overflow."
736 ++ showSDoc dflags (ppr $ widthToLlvmInt w)
737 MO_SubIntC w -> fsLit $ "llvm.ssub.with.overflow."
738 ++ showSDoc dflags (ppr $ widthToLlvmInt w)
739 MO_Add2 w -> fsLit $ "llvm.uadd.with.overflow."
740 ++ showSDoc dflags (ppr $ widthToLlvmInt w)
741 MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow."
742 ++ showSDoc dflags (ppr $ widthToLlvmInt w)
743
744 MO_S_QuotRem {} -> unsupported
745 MO_U_QuotRem {} -> unsupported
746 MO_U_QuotRem2 {} -> unsupported
747 -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the
748 -- appropriate case of genCall.
749 MO_U_Mul2 {} -> unsupported
750 MO_WriteBarrier -> unsupported
751 MO_Touch -> unsupported
752 MO_UF_Conv _ -> unsupported
753
754 MO_AtomicRead _ -> unsupported
755 MO_AtomicRMW _ _ -> unsupported
756 MO_AtomicWrite _ -> unsupported
757 MO_Cmpxchg _ -> unsupported
758
759 -- | Tail function calls
760 genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData
761
762 -- Call to known function
763 genJump (CmmLit (CmmLabel lbl)) live = do
764 (vf, stmts, top) <- getHsFunc live lbl
765 (stgRegs, stgStmts) <- funEpilogue live
766 let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
767 let s2 = Return Nothing
768 return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
769
770
771 -- Call to unknown function / address
772 genJump expr live = do
773 fty <- llvmFunTy live
774 (vf, stmts, top) <- exprToVar expr
775 dflags <- getDynFlags
776
777 let cast = case getVarType vf of
778 ty | isPointer ty -> LM_Bitcast
779 ty | isInt ty -> LM_Inttoptr
780
781 ty -> panic $ "genJump: Expr is of bad type for function call! ("
782 ++ showSDoc dflags (ppr ty) ++ ")"
783
784 (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
785 (stgRegs, stgStmts) <- funEpilogue live
786 let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
787 let s3 = Return Nothing
788 return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
789 top)
790
791
792 -- | CmmAssign operation
793 --
794 -- We use stack allocated variables for CmmReg. The optimiser will replace
795 -- these with registers when possible.
796 genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData
797 genAssign reg val = do
798 vreg <- getCmmReg reg
799 (vval, stmts2, top2) <- exprToVar val
800 let stmts = stmts2
801
802 let ty = (pLower . getVarType) vreg
803 dflags <- getDynFlags
804 case ty of
805 -- Some registers are pointer types, so need to cast value to pointer
806 LMPointer _ | getVarType vval == llvmWord dflags -> do
807 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
808 let s2 = Store v vreg
809 return (stmts `snocOL` s1 `snocOL` s2, top2)
810
811 LMVector _ _ -> do
812 (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty
813 let s2 = Store v vreg
814 return (stmts `snocOL` s1 `snocOL` s2, top2)
815
816 _ -> do
817 let s1 = Store vval vreg
818 return (stmts `snocOL` s1, top2)
819
820
821 -- | CmmStore operation
822 genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData
823
824 -- First we try to detect a few common cases and produce better code for
825 -- these then the default case. We are mostly trying to detect Cmm code
826 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
827 -- generic case that uses casts and pointer arithmetic
828 genStore addr@(CmmReg (CmmGlobal r)) val
829 = genStore_fast addr r 0 val
830
831 genStore addr@(CmmRegOff (CmmGlobal r) n) val
832 = genStore_fast addr r n val
833
834 genStore addr@(CmmMachOp (MO_Add _) [
835 (CmmReg (CmmGlobal r)),
836 (CmmLit (CmmInt n _))])
837 val
838 = genStore_fast addr r (fromInteger n) val
839
840 genStore addr@(CmmMachOp (MO_Sub _) [
841 (CmmReg (CmmGlobal r)),
842 (CmmLit (CmmInt n _))])
843 val
844 = genStore_fast addr r (negate $ fromInteger n) val
845
846 -- generic case
847 genStore addr val
848 = do other <- getTBAAMeta otherN
849 genStore_slow addr val other
850
851 -- | CmmStore operation
852 -- This is a special case for storing to a global register pointer
853 -- offset such as I32[Sp+8].
854 genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr
855 -> LlvmM StmtData
856 genStore_fast addr r n val
857 = do dflags <- getDynFlags
858 (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
859 meta <- getTBAARegMeta r
860 let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
861 case isPointer grt && rem == 0 of
862 True -> do
863 (vval, stmts, top) <- exprToVar val
864 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
865 -- We might need a different pointer type, so check
866 case pLower grt == getVarType vval of
867 -- were fine
868 True -> do
869 let s3 = MetaStmt meta $ Store vval ptr
870 return (stmts `appOL` s1 `snocOL` s2
871 `snocOL` s3, top)
872
873 -- cast to pointer type needed
874 False -> do
875 let ty = (pLift . getVarType) vval
876 (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
877 let s4 = MetaStmt meta $ Store vval ptr'
878 return (stmts `appOL` s1 `snocOL` s2
879 `snocOL` s3 `snocOL` s4, top)
880
881 -- If its a bit type then we use the slow method since
882 -- we can't avoid casting anyway.
883 False -> genStore_slow addr val meta
884
885
886 -- | CmmStore operation
887 -- Generic case. Uses casts and pointer arithmetic if needed.
888 genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData
889 genStore_slow addr val meta = do
890 (vaddr, stmts1, top1) <- exprToVar addr
891 (vval, stmts2, top2) <- exprToVar val
892
893 let stmts = stmts1 `appOL` stmts2
894 dflags <- getDynFlags
895 case getVarType vaddr of
896 -- sometimes we need to cast an int to a pointer before storing
897 LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do
898 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
899 let s2 = MetaStmt meta $ Store v vaddr
900 return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
901
902 LMPointer _ -> do
903 let s1 = MetaStmt meta $ Store vval vaddr
904 return (stmts `snocOL` s1, top1 ++ top2)
905
906 i@(LMInt _) | i == llvmWord dflags -> do
907 let vty = pLift $ getVarType vval
908 (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
909 let s2 = MetaStmt meta $ Store vval vptr
910 return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
911
912 other ->
913 pprPanic "genStore: ptr not right type!"
914 (PprCmm.pprExpr addr <+> text (
915 "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
916 ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
917 ", Var: " ++ showSDoc dflags (ppr vaddr)))
918
919
920 -- | Unconditional branch
921 genBranch :: BlockId -> LlvmM StmtData
922 genBranch id =
923 let label = blockIdToLlvm id
924 in return (unitOL $ Branch label, [])
925
926
927 -- | Conditional branch
928 genCondBranch :: CmmExpr -> BlockId -> BlockId -> LlvmM StmtData
929 genCondBranch cond idT idF = do
930 let labelT = blockIdToLlvm idT
931 let labelF = blockIdToLlvm idF
932 -- See Note [Literals and branch conditions].
933 (vc, stmts, top) <- exprToVarOpt i1Option cond
934 if getVarType vc == i1
935 then do
936 let s1 = BranchIf vc labelT labelF
937 return (stmts `snocOL` s1, top)
938 else do
939 dflags <- getDynFlags
940 panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"
941
942 {- Note [Literals and branch conditions]
943 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
944
945 It is important that whenever we generate branch conditions for
946 literals like '1', they are properly narrowed to an LLVM expression of
947 type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
948 a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
949 must be certain to return a properly narrowed type. genLit is
950 responsible for this, in the case of literal integers.
951
952 Often, we won't see direct statements like:
953
954 if(1) {
955 ...
956 } else {
957 ...
958 }
959
960 at this point in the pipeline, because the Glorious Code Generator
961 will do trivial branch elimination in the sinking pass (among others,)
962 which will eliminate the expression entirely.
963
964 However, it's certainly possible and reasonable for this to occur in
965 hand-written C-- code. Consider something like:
966
967 #ifndef SOME_CONDITIONAL
968 #define CHECK_THING(x) 1
969 #else
970 #define CHECK_THING(x) some_operation((x))
971 #endif
972
973 f() {
974
975 if (CHECK_THING(xyz)) {
976 ...
977 } else {
978 ...
979 }
980
981 }
982
983 In such an instance, CHECK_THING might result in an *expression* in
984 one case, and a *literal* in the other, depending on what in
985 particular was #define'd. So we must be sure to properly narrow the
986 literal in this case to i1 as it won't be eliminated beforehand.
987
988 For a real example of this, see ./rts/StgStdThunks.cmm
989
990 -}
991
992
993
994 -- | Switch branch
995 genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData
996 genSwitch cond ids = do
997 (vc, stmts, top) <- exprToVar cond
998 let ty = getVarType vc
999
1000 let labels = [ (mkIntLit ty ix, blockIdToLlvm b)
1001 | (ix, b) <- switchTargetsCases ids ]
1002 -- out of range is undefined, so let's just branch to first label
1003 let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l
1004 | otherwise = snd (head labels)
1005
1006 let s1 = Switch vc defLbl labels
1007 return $ (stmts `snocOL` s1, top)
1008
1009
1010 -- -----------------------------------------------------------------------------
1011 -- * CmmExpr code generation
1012 --
1013
1014 -- | An expression conversion return data:
1015 -- * LlvmVar: The var holding the result of the expression
1016 -- * LlvmStatements: Any statements needed to evaluate the expression
1017 -- * LlvmCmmDecl: Any global data needed for this expression
1018 type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])
1019
1020 -- | Values which can be passed to 'exprToVar' to configure its
1021 -- behaviour in certain circumstances.
1022 --
1023 -- Currently just used for determining if a comparison should return
1024 -- a boolean (i1) or a word. See Note [Literals and branch conditions].
1025 newtype EOption = EOption { i1Expected :: Bool }
1026 -- XXX: EOption is an ugly and inefficient solution to this problem.
1027
1028 -- | i1 type expected (condition scrutinee).
1029 i1Option :: EOption
1030 i1Option = EOption True
1031
1032 -- | Word type expected (usual).
1033 wordOption :: EOption
1034 wordOption = EOption False
1035
1036 -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
1037 -- expression being stored in the returned LlvmVar.
1038 exprToVar :: CmmExpr -> LlvmM ExprData
1039 exprToVar = exprToVarOpt wordOption
1040
1041 exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData
1042 exprToVarOpt opt e = case e of
1043
1044 CmmLit lit
1045 -> genLit opt lit
1046
1047 CmmLoad e' ty
1048 -> genLoad False e' ty
1049
1050 -- Cmmreg in expression is the value, so must load. If you want actual
1051 -- reg pointer, call getCmmReg directly.
1052 CmmReg r -> do
1053 (v1, ty, s1) <- getCmmRegVal r
1054 case isPointer ty of
1055 True -> do
1056 -- Cmm wants the value, so pointer types must be cast to ints
1057 dflags <- getDynFlags
1058 (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)
1059 return (v2, s1 `snocOL` s2, [])
1060
1061 False -> return (v1, s1, [])
1062
1063 CmmMachOp op exprs
1064 -> genMachOp opt op exprs
1065
1066 CmmRegOff r i
1067 -> do dflags <- getDynFlags
1068 exprToVar $ expandCmmReg dflags (r, i)
1069
1070 CmmStackSlot _ _
1071 -> panic "exprToVar: CmmStackSlot not supported!"
1072
1073
1074 -- | Handle CmmMachOp expressions
1075 genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
1076
1077 -- Unary Machop
1078 genMachOp _ op [x] = case op of
1079
1080 MO_Not w ->
1081 let all1 = mkIntLit (widthToLlvmInt w) (-1)
1082 in negate (widthToLlvmInt w) all1 LM_MO_Xor
1083
1084 MO_S_Neg w ->
1085 let all0 = mkIntLit (widthToLlvmInt w) 0
1086 in negate (widthToLlvmInt w) all0 LM_MO_Sub
1087
1088 MO_F_Neg w ->
1089 let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
1090 in negate (widthToLlvmFloat w) all0 LM_MO_FSub
1091
1092 MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
1093 MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
1094
1095 MO_SS_Conv from to
1096 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
1097
1098 MO_UU_Conv from to
1099 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
1100
1101 MO_FF_Conv from to
1102 -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
1103
1104 MO_VS_Neg len w ->
1105 let ty = widthToLlvmInt w
1106 vecty = LMVector len ty
1107 all0 = LMIntLit (-0) ty
1108 all0s = LMLitVar $ LMVectorLit (replicate len all0)
1109 in negateVec vecty all0s LM_MO_Sub
1110
1111 MO_VF_Neg len w ->
1112 let ty = widthToLlvmFloat w
1113 vecty = LMVector len ty
1114 all0 = LMFloatLit (-0) ty
1115 all0s = LMLitVar $ LMVectorLit (replicate len all0)
1116 in negateVec vecty all0s LM_MO_FSub
1117
1118 -- Handle unsupported cases explicitly so we get a warning
1119 -- of missing case when new MachOps added
1120 MO_Add _ -> panicOp
1121 MO_Mul _ -> panicOp
1122 MO_Sub _ -> panicOp
1123 MO_S_MulMayOflo _ -> panicOp
1124 MO_S_Quot _ -> panicOp
1125 MO_S_Rem _ -> panicOp
1126 MO_U_MulMayOflo _ -> panicOp
1127 MO_U_Quot _ -> panicOp
1128 MO_U_Rem _ -> panicOp
1129
1130 MO_Eq _ -> panicOp
1131 MO_Ne _ -> panicOp
1132 MO_S_Ge _ -> panicOp
1133 MO_S_Gt _ -> panicOp
1134 MO_S_Le _ -> panicOp
1135 MO_S_Lt _ -> panicOp
1136 MO_U_Ge _ -> panicOp
1137 MO_U_Gt _ -> panicOp
1138 MO_U_Le _ -> panicOp
1139 MO_U_Lt _ -> panicOp
1140
1141 MO_F_Add _ -> panicOp
1142 MO_F_Sub _ -> panicOp
1143 MO_F_Mul _ -> panicOp
1144 MO_F_Quot _ -> panicOp
1145 MO_F_Eq _ -> panicOp
1146 MO_F_Ne _ -> panicOp
1147 MO_F_Ge _ -> panicOp
1148 MO_F_Gt _ -> panicOp
1149 MO_F_Le _ -> panicOp
1150 MO_F_Lt _ -> panicOp
1151
1152 MO_And _ -> panicOp
1153 MO_Or _ -> panicOp
1154 MO_Xor _ -> panicOp
1155 MO_Shl _ -> panicOp
1156 MO_U_Shr _ -> panicOp
1157 MO_S_Shr _ -> panicOp
1158
1159 MO_V_Insert _ _ -> panicOp
1160 MO_V_Extract _ _ -> panicOp
1161
1162 MO_V_Add _ _ -> panicOp
1163 MO_V_Sub _ _ -> panicOp
1164 MO_V_Mul _ _ -> panicOp
1165
1166 MO_VS_Quot _ _ -> panicOp
1167 MO_VS_Rem _ _ -> panicOp
1168
1169 MO_VU_Quot _ _ -> panicOp
1170 MO_VU_Rem _ _ -> panicOp
1171
1172 MO_VF_Insert _ _ -> panicOp
1173 MO_VF_Extract _ _ -> panicOp
1174
1175 MO_VF_Add _ _ -> panicOp
1176 MO_VF_Sub _ _ -> panicOp
1177 MO_VF_Mul _ _ -> panicOp
1178 MO_VF_Quot _ _ -> panicOp
1179
1180 where
1181 negate ty v2 negOp = do
1182 (vx, stmts, top) <- exprToVar x
1183 (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
1184 return (v1, stmts `snocOL` s1, top)
1185
1186 negateVec ty v2 negOp = do
1187 (vx, stmts1, top) <- exprToVar x
1188 ([vx'], stmts2) <- castVars [(vx, ty)]
1189 (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
1190 return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
1191
1192 fiConv ty convOp = do
1193 (vx, stmts, top) <- exprToVar x
1194 (v1, s1) <- doExpr ty $ Cast convOp vx ty
1195 return (v1, stmts `snocOL` s1, top)
1196
1197 sameConv from ty reduce expand = do
1198 x'@(vx, stmts, top) <- exprToVar x
1199 let sameConv' op = do
1200 (v1, s1) <- doExpr ty $ Cast op vx ty
1201 return (v1, stmts `snocOL` s1, top)
1202 dflags <- getDynFlags
1203 let toWidth = llvmWidthInBits dflags ty
1204 -- LLVM doesn't like trying to convert to same width, so
1205 -- need to check for that as we do get Cmm code doing it.
1206 case widthInBits from of
1207 w | w < toWidth -> sameConv' expand
1208 w | w > toWidth -> sameConv' reduce
1209 _w -> return x'
1210
1211 panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered"
1212 ++ "with one argument! (" ++ show op ++ ")"
1213
1214 -- Handle GlobalRegs pointers
1215 genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
1216 = genMachOp_fast opt o r (fromInteger n) e
1217
1218 genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
1219 = genMachOp_fast opt o r (negate . fromInteger $ n) e
1220
1221 -- Generic case
1222 genMachOp opt op e = genMachOp_slow opt op e
1223
1224
1225 -- | Handle CmmMachOp expressions
1226 -- This is a specialised method that handles Global register manipulations like
1227 -- 'Sp - 16', using the getelementptr instruction.
1228 genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
1229 -> LlvmM ExprData
1230 genMachOp_fast opt op r n e
1231 = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
1232 dflags <- getDynFlags
1233 let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
1234 case isPointer grt && rem == 0 of
1235 True -> do
1236 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
1237 (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)
1238 return (var, s1 `snocOL` s2 `snocOL` s3, [])
1239
1240 False -> genMachOp_slow opt op e
1241
1242
1243 -- | Handle CmmMachOp expressions
1244 -- This handles all the cases not handle by the specialised genMachOp_fast.
1245 genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
1246
1247 -- Element extraction
1248 genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
1249 vval <- exprToVarW val
1250 vidx <- exprToVarW idx
1251 [vval'] <- castVarsW [(vval, LMVector l ty)]
1252 doExprW ty $ Extract vval' vidx
1253 where
1254 ty = widthToLlvmInt w
1255
1256 genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do
1257 vval <- exprToVarW val
1258 vidx <- exprToVarW idx
1259 [vval'] <- castVarsW [(vval, LMVector l ty)]
1260 doExprW ty $ Extract vval' vidx
1261 where
1262 ty = widthToLlvmFloat w
1263
1264 -- Element insertion
1265 genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do
1266 vval <- exprToVarW val
1267 velt <- exprToVarW elt
1268 vidx <- exprToVarW idx
1269 [vval'] <- castVarsW [(vval, ty)]
1270 doExprW ty $ Insert vval' velt vidx
1271 where
1272 ty = LMVector l (widthToLlvmInt w)
1273
1274 genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do
1275 vval <- exprToVarW val
1276 velt <- exprToVarW elt
1277 vidx <- exprToVarW idx
1278 [vval'] <- castVarsW [(vval, ty)]
1279 doExprW ty $ Insert vval' velt vidx
1280 where
1281 ty = LMVector l (widthToLlvmFloat w)
1282
1283 -- Binary MachOp
1284 genMachOp_slow opt op [x, y] = case op of
1285
1286 MO_Eq _ -> genBinComp opt LM_CMP_Eq
1287 MO_Ne _ -> genBinComp opt LM_CMP_Ne
1288
1289 MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
1290 MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
1291 MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
1292 MO_S_Le _ -> genBinComp opt LM_CMP_Sle
1293
1294 MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
1295 MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
1296 MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
1297 MO_U_Le _ -> genBinComp opt LM_CMP_Ule
1298
1299 MO_Add _ -> genBinMach LM_MO_Add
1300 MO_Sub _ -> genBinMach LM_MO_Sub
1301 MO_Mul _ -> genBinMach LM_MO_Mul
1302
1303 MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
1304
1305 MO_S_MulMayOflo w -> isSMulOK w x y
1306
1307 MO_S_Quot _ -> genBinMach LM_MO_SDiv
1308 MO_S_Rem _ -> genBinMach LM_MO_SRem
1309
1310 MO_U_Quot _ -> genBinMach LM_MO_UDiv
1311 MO_U_Rem _ -> genBinMach LM_MO_URem
1312
1313 MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
1314 MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
1315 MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
1316 MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
1317 MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
1318 MO_F_Le _ -> genBinComp opt LM_CMP_Fle
1319
1320 MO_F_Add _ -> genBinMach LM_MO_FAdd
1321 MO_F_Sub _ -> genBinMach LM_MO_FSub
1322 MO_F_Mul _ -> genBinMach LM_MO_FMul
1323 MO_F_Quot _ -> genBinMach LM_MO_FDiv
1324
1325 MO_And _ -> genBinMach LM_MO_And
1326 MO_Or _ -> genBinMach LM_MO_Or
1327 MO_Xor _ -> genBinMach LM_MO_Xor
1328 MO_Shl _ -> genBinMach LM_MO_Shl
1329 MO_U_Shr _ -> genBinMach LM_MO_LShr
1330 MO_S_Shr _ -> genBinMach LM_MO_AShr
1331
1332 MO_V_Add l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add
1333 MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub
1334 MO_V_Mul l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul
1335
1336 MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv
1337 MO_VS_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem
1338
1339 MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv
1340 MO_VU_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem
1341
1342 MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd
1343 MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub
1344 MO_VF_Mul l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul
1345 MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv
1346
1347 MO_Not _ -> panicOp
1348 MO_S_Neg _ -> panicOp
1349 MO_F_Neg _ -> panicOp
1350
1351 MO_SF_Conv _ _ -> panicOp
1352 MO_FS_Conv _ _ -> panicOp
1353 MO_SS_Conv _ _ -> panicOp
1354 MO_UU_Conv _ _ -> panicOp
1355 MO_FF_Conv _ _ -> panicOp
1356
1357 MO_V_Insert {} -> panicOp
1358 MO_V_Extract {} -> panicOp
1359
1360 MO_VS_Neg {} -> panicOp
1361
1362 MO_VF_Insert {} -> panicOp
1363 MO_VF_Extract {} -> panicOp
1364
1365 MO_VF_Neg {} -> panicOp
1366
1367 where
1368 binLlvmOp ty binOp = runExprData $ do
1369 vx <- exprToVarW x
1370 vy <- exprToVarW y
1371 if getVarType vx == getVarType vy
1372 then do
1373 doExprW (ty vx) $ binOp vx vy
1374
1375 else do
1376 -- Error. Continue anyway so we can debug the generated ll file.
1377 dflags <- lift getDynFlags
1378 let style = mkCodeStyle CStyle
1379 toString doc = renderWithStyle dflags doc style
1380 cmmToStr = (lines . toString . PprCmm.pprExpr)
1381 statement $ Comment $ map fsLit $ cmmToStr x
1382 statement $ Comment $ map fsLit $ cmmToStr y
1383 doExprW (ty vx) $ binOp vx vy
1384
1385 binCastLlvmOp ty binOp = runExprData $ do
1386 vx <- exprToVarW x
1387 vy <- exprToVarW y
1388 [vx', vy'] <- castVarsW [(vx, ty), (vy, ty)]
1389 doExprW ty $ binOp vx' vy'
1390
1391 -- | Need to use EOption here as Cmm expects word size results from
1392 -- comparisons while LLVM return i1. Need to extend to llvmWord type
1393 -- if expected. See Note [Literals and branch conditions].
1394 genBinComp opt cmp = do
1395 ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
1396 dflags <- getDynFlags
1397 if getVarType v1 == i1
1398 then case i1Expected opt of
1399 True -> return ed
1400 False -> do
1401 let w_ = llvmWord dflags
1402 (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
1403 return (v2, stmts `snocOL` s1, top)
1404 else
1405 panic $ "genBinComp: Compare returned type other then i1! "
1406 ++ (showSDoc dflags $ ppr $ getVarType v1)
1407
1408 genBinMach op = binLlvmOp getVarType (LlvmOp op)
1409
1410 genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)
1411
1412 -- | Detect if overflow will occur in signed multiply of the two
1413 -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
1414 -- implementation. Its much longer due to type information/safety.
1415 -- This should actually compile to only about 3 asm instructions.
1416 isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
1417 isSMulOK _ x y = runExprData $ do
1418 vx <- exprToVarW x
1419 vy <- exprToVarW y
1420
1421 dflags <- lift getDynFlags
1422 let word = getVarType vx
1423 let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
1424 let shift = llvmWidthInBits dflags word
1425 let shift1 = toIWord dflags (shift - 1)
1426 let shift2 = toIWord dflags shift
1427
1428 if isInt word
1429 then do
1430 x1 <- doExprW word2 $ Cast LM_Sext vx word2
1431 y1 <- doExprW word2 $ Cast LM_Sext vy word2
1432 r1 <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1
1433 rlow1 <- doExprW word $ Cast LM_Trunc r1 word
1434 rlow2 <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1
1435 rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2
1436 rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word
1437 doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2
1438
1439 else
1440 panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"
1441
1442 panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"
1443 ++ "with two arguments! (" ++ show op ++ ")"
1444
1445 -- More then two expression, invalid!
1446 genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
1447
1448
1449 -- | Handle CmmLoad expression.
1450 genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData
1451
1452 -- First we try to detect a few common cases and produce better code for
1453 -- these then the default case. We are mostly trying to detect Cmm code
1454 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
1455 -- generic case that uses casts and pointer arithmetic
1456 genLoad atomic e@(CmmReg (CmmGlobal r)) ty
1457 = genLoad_fast atomic e r 0 ty
1458
1459 genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty
1460 = genLoad_fast atomic e r n ty
1461
1462 genLoad atomic e@(CmmMachOp (MO_Add _) [
1463 (CmmReg (CmmGlobal r)),
1464 (CmmLit (CmmInt n _))])
1465 ty
1466 = genLoad_fast atomic e r (fromInteger n) ty
1467
1468 genLoad atomic e@(CmmMachOp (MO_Sub _) [
1469 (CmmReg (CmmGlobal r)),
1470 (CmmLit (CmmInt n _))])
1471 ty
1472 = genLoad_fast atomic e r (negate $ fromInteger n) ty
1473
1474 -- generic case
1475 genLoad atomic e ty
1476 = do other <- getTBAAMeta otherN
1477 genLoad_slow atomic e ty other
1478
1479 -- | Handle CmmLoad expression.
1480 -- This is a special case for loading from a global register pointer
1481 -- offset such as I32[Sp+8].
1482 genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType
1483 -> LlvmM ExprData
1484 genLoad_fast atomic e r n ty = do
1485 dflags <- getDynFlags
1486 (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
1487 meta <- getTBAARegMeta r
1488 let ty' = cmmToLlvmType ty
1489 (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
1490 case isPointer grt && rem == 0 of
1491 True -> do
1492 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
1493 -- We might need a different pointer type, so check
1494 case grt == ty' of
1495 -- were fine
1496 True -> do
1497 (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr)
1498 return (var, s1 `snocOL` s2 `snocOL` s3,
1499 [])
1500
1501 -- cast to pointer type needed
1502 False -> do
1503 let pty = pLift ty'
1504 (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
1505 (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr')
1506 return (var, s1 `snocOL` s2 `snocOL` s3
1507 `snocOL` s4, [])
1508
1509 -- If its a bit type then we use the slow method since
1510 -- we can't avoid casting anyway.
1511 False -> genLoad_slow atomic e ty meta
1512 where
1513 loadInstr ptr | atomic = ALoad SyncSeqCst False ptr
1514 | otherwise = Load ptr
1515
1516 -- | Handle Cmm load expression.
1517 -- Generic case. Uses casts and pointer arithmetic if needed.
1518 genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
1519 genLoad_slow atomic e ty meta = runExprData $ do
1520 iptr <- exprToVarW e
1521 dflags <- lift getDynFlags
1522 case getVarType iptr of
1523 LMPointer _ -> do
1524 doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr)
1525
1526 i@(LMInt _) | i == llvmWord dflags -> do
1527 let pty = LMPointer $ cmmToLlvmType ty
1528 ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty
1529 doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr)
1530
1531 other -> do pprPanic "exprToVar: CmmLoad expression is not right type!"
1532 (PprCmm.pprExpr e <+> text (
1533 "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
1534 ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
1535 ", Var: " ++ showSDoc dflags (ppr iptr)))
1536 where
1537 loadInstr ptr | atomic = ALoad SyncSeqCst False ptr
1538 | otherwise = Load ptr
1539
1540
1541 -- | Handle CmmReg expression. This will return a pointer to the stack
1542 -- location of the register. Throws an error if it isn't allocated on
1543 -- the stack.
1544 getCmmReg :: CmmReg -> LlvmM LlvmVar
1545 getCmmReg (CmmLocal (LocalReg un _))
1546 = do exists <- varLookup un
1547 dflags <- getDynFlags
1548 case exists of
1549 Just ety -> return (LMLocalVar un $ pLift ety)
1550 Nothing -> fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"
1551 -- This should never happen, as every local variable should
1552 -- have been assigned a value at some point, triggering
1553 -- "funPrologue" to allocate it on the stack.
1554
1555 getCmmReg (CmmGlobal g)
1556 = do onStack <- checkStackReg g
1557 dflags <- getDynFlags
1558 if onStack
1559 then return (lmGlobalRegVar dflags g)
1560 else fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"
1561
1562 -- | Return the value of a given register, as well as its type. Might
1563 -- need to be load from stack.
1564 getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
1565 getCmmRegVal reg =
1566 case reg of
1567 CmmGlobal g -> do
1568 onStack <- checkStackReg g
1569 dflags <- getDynFlags
1570 if onStack then loadFromStack else do
1571 let r = lmGlobalRegArg dflags g
1572 return (r, getVarType r, nilOL)
1573 _ -> loadFromStack
1574 where loadFromStack = do
1575 ptr <- getCmmReg reg
1576 let ty = pLower $ getVarType ptr
1577 (v, s) <- doExpr ty (Load ptr)
1578 return (v, ty, unitOL s)
1579
1580 -- | Allocate a local CmmReg on the stack
1581 allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
1582 allocReg (CmmLocal (LocalReg un ty))
1583 = let ty' = cmmToLlvmType ty
1584 var = LMLocalVar un (LMPointer ty')
1585 alc = Alloca ty' 1
1586 in (var, unitOL $ Assignment var alc)
1587
1588 allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
1589 ++ " have been handled elsewhere!"
1590
1591
1592 -- | Generate code for a literal
1593 genLit :: EOption -> CmmLit -> LlvmM ExprData
1594 genLit opt (CmmInt i w)
1595 -- See Note [Literals and branch conditions].
1596 = let width | i1Expected opt = i1
1597 | otherwise = LMInt (widthInBits w)
1598 -- comm = Comment [ fsLit $ "EOption: " ++ show opt
1599 -- , fsLit $ "Width : " ++ show w
1600 -- , fsLit $ "Width' : " ++ show (widthInBits w)
1601 -- ]
1602 in return (mkIntLit width i, nilOL, [])
1603
1604 genLit _ (CmmFloat r w)
1605 = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
1606 nilOL, [])
1607
1608 genLit opt (CmmVec ls)
1609 = do llvmLits <- mapM toLlvmLit ls
1610 return (LMLitVar $ LMVectorLit llvmLits, nilOL, [])
1611 where
1612 toLlvmLit :: CmmLit -> LlvmM LlvmLit
1613 toLlvmLit lit = do
1614 (llvmLitVar, _, _) <- genLit opt lit
1615 case llvmLitVar of
1616 LMLitVar llvmLit -> return llvmLit
1617 _ -> panic "genLit"
1618
1619 genLit _ cmm@(CmmLabel l)
1620 = do var <- getGlobalPtr =<< strCLabel_llvm l
1621 dflags <- getDynFlags
1622 let lmty = cmmToLlvmType $ cmmLitType dflags cmm
1623 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
1624 return (v1, unitOL s1, [])
1625
1626 genLit opt (CmmLabelOff label off) = do
1627 dflags <- getDynFlags
1628 (vlbl, stmts, stat) <- genLit opt (CmmLabel label)
1629 let voff = toIWord dflags off
1630 (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
1631 return (v1, stmts `snocOL` s1, stat)
1632
1633 genLit opt (CmmLabelDiffOff l1 l2 off) = do
1634 dflags <- getDynFlags
1635 (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)
1636 (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)
1637 let voff = toIWord dflags off
1638 let ty1 = getVarType vl1
1639 let ty2 = getVarType vl2
1640 if (isInt ty1) && (isInt ty2)
1641 && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)
1642
1643 then do
1644 (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
1645 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
1646 return (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
1647 stat1 ++ stat2)
1648
1649 else
1650 panic "genLit: CmmLabelDiffOff encountered with different label ty!"
1651
1652 genLit opt (CmmBlock b)
1653 = genLit opt (CmmLabel $ infoTblLbl b)
1654
1655 genLit _ CmmHighStackMark
1656 = panic "genStaticLit - CmmHighStackMark unsupported!"
1657
1658
1659 -- -----------------------------------------------------------------------------
1660 -- * Misc
1661 --
1662
1663 -- | Find CmmRegs that get assigned and allocate them on the stack
1664 --
1665 -- Any register that gets written needs to be allcoated on the
1666 -- stack. This avoids having to map a CmmReg to an equivalent SSA form
1667 -- and avoids having to deal with Phi node insertion. This is also
1668 -- the approach recommended by LLVM developers.
1669 --
1670 -- On the other hand, this is unecessarily verbose if the register in
1671 -- question is never written. Therefore we skip it where we can to
1672 -- save a few lines in the output and hopefully speed compilation up a
1673 -- bit.
1674 funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData
1675 funPrologue live cmmBlocks = do
1676
1677 trash <- getTrashRegs
1678 let getAssignedRegs :: CmmNode O O -> [CmmReg]
1679 getAssignedRegs (CmmAssign reg _) = [reg]
1680 -- Calls will trash all registers. Unfortunately, this needs them to
1681 -- be stack-allocated in the first place.
1682 getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs
1683 getAssignedRegs _ = []
1684 getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body
1685 assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks
1686 isLive r = r `elem` alwaysLive || r `elem` live
1687
1688 dflags <- getDynFlags
1689 stmtss <- flip mapM assignedRegs $ \reg ->
1690 case reg of
1691 CmmLocal (LocalReg un _) -> do
1692 let (newv, stmts) = allocReg reg
1693 varInsert un (pLower $ getVarType newv)
1694 return stmts
1695 CmmGlobal r -> do
1696 let reg = lmGlobalRegVar dflags r
1697 arg = lmGlobalRegArg dflags r
1698 ty = (pLower . getVarType) reg
1699 trash = LMLitVar $ LMUndefLit ty
1700 rval = if isLive r then arg else trash
1701 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
1702 markStackReg r
1703 return $ toOL [alloc, Store rval reg]
1704
1705 return (concatOL stmtss, [])
1706
1707 -- | Function epilogue. Load STG variables to use as argument for call.
1708 -- STG Liveness optimisation done here.
1709 funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
1710 funEpilogue live = do
1711
1712 -- Have information and liveness optimisation is enabled?
1713 let liveRegs = alwaysLive ++ live
1714 isSSE (FloatReg _) = True
1715 isSSE (DoubleReg _) = True
1716 isSSE (XmmReg _) = True
1717 isSSE (YmmReg _) = True
1718 isSSE (ZmmReg _) = True
1719 isSSE _ = False
1720
1721 -- Set to value or "undef" depending on whether the register is
1722 -- actually live
1723 dflags <- getDynFlags
1724 let loadExpr r = do
1725 (v, _, s) <- getCmmRegVal (CmmGlobal r)
1726 return (Just $ v, s)
1727 loadUndef r = do
1728 let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
1729 return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
1730 platform <- getDynFlag targetPlatform
1731 loads <- flip mapM (activeStgRegs platform) $ \r -> case () of
1732 _ | r `elem` liveRegs -> loadExpr r
1733 | not (isSSE r) -> loadUndef r
1734 | otherwise -> return (Nothing, nilOL)
1735
1736 let (vars, stmts) = unzip loads
1737 return (catMaybes vars, concatOL stmts)
1738
1739
1740 -- | A series of statements to trash all the STG registers.
1741 --
1742 -- In LLVM we pass the STG registers around everywhere in function calls.
1743 -- So this means LLVM considers them live across the entire function, when
1744 -- in reality they usually aren't. For Caller save registers across C calls
1745 -- the saving and restoring of them is done by the Cmm code generator,
1746 -- using Cmm local vars. So to stop LLVM saving them as well (and saving
1747 -- all of them since it thinks they're always live, we trash them just
1748 -- before the call by assigning the 'undef' value to them. The ones we
1749 -- need are restored from the Cmm local var and the ones we don't need
1750 -- are fine to be trashed.
1751 getTrashStmts :: LlvmM LlvmStatements
1752 getTrashStmts = do
1753 regs <- getTrashRegs
1754 stmts <- flip mapM regs $ \ r -> do
1755 reg <- getCmmReg (CmmGlobal r)
1756 let ty = (pLower . getVarType) reg
1757 return $ Store (LMLitVar $ LMUndefLit ty) reg
1758 return $ toOL stmts
1759
1760 getTrashRegs :: LlvmM [GlobalReg]
1761 getTrashRegs = do plat <- getLlvmPlatform
1762 return $ filter (callerSaves plat) (activeStgRegs plat)
1763
1764 -- | Get a function pointer to the CLabel specified.
1765 --
1766 -- This is for Haskell functions, function type is assumed, so doesn't work
1767 -- with foreign functions.
1768 getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData
1769 getHsFunc live lbl
1770 = do fty <- llvmFunTy live
1771 name <- strCLabel_llvm lbl
1772 getHsFunc' name fty
1773
1774 getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData
1775 getHsFunc' name fty
1776 = do fun <- getGlobalPtr name
1777 if getVarType fun == fty
1778 then return (fun, nilOL, [])
1779 else do (v1, s1) <- doExpr (pLift fty)
1780 $ Cast LM_Bitcast fun (pLift fty)
1781 return (v1, unitOL s1, [])
1782
1783 -- | Create a new local var
1784 mkLocalVar :: LlvmType -> LlvmM LlvmVar
1785 mkLocalVar ty = do
1786 un <- runUs getUniqueM
1787 return $ LMLocalVar un ty
1788
1789
1790 -- | Execute an expression, assigning result to a var
1791 doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
1792 doExpr ty expr = do
1793 v <- mkLocalVar ty
1794 return (v, Assignment v expr)
1795
1796
1797 -- | Expand CmmRegOff
1798 expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr
1799 expandCmmReg dflags (reg, off)
1800 = let width = typeWidth (cmmRegType dflags reg)
1801 voff = CmmLit $ CmmInt (fromIntegral off) width
1802 in CmmMachOp (MO_Add width) [CmmReg reg, voff]
1803
1804
1805 -- | Convert a block id into a appropriate Llvm label
1806 blockIdToLlvm :: BlockId -> LlvmVar
1807 blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
1808
1809 -- | Create Llvm int Literal
1810 mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
1811 mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
1812
1813 -- | Convert int type to a LLvmVar of word or i32 size
1814 toI32 :: Integral a => a -> LlvmVar
1815 toI32 = mkIntLit i32
1816
1817 toIWord :: Integral a => DynFlags -> a -> LlvmVar
1818 toIWord dflags = mkIntLit (llvmWord dflags)
1819
1820
1821 -- | Error functions
1822 panic :: String -> a
1823 panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
1824
1825 pprPanic :: String -> SDoc -> a
1826 pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d
1827
1828
1829 -- | Returns TBAA meta data by unique
1830 getTBAAMeta :: Unique -> LlvmM [MetaAnnot]
1831 getTBAAMeta u = do
1832 mi <- getUniqMeta u
1833 return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]
1834
1835 -- | Returns TBAA meta data for given register
1836 getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]
1837 getTBAARegMeta = getTBAAMeta . getTBAA
1838
1839
1840 -- | A more convenient way of accumulating LLVM statements and declarations.
1841 data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl]
1842
1843 instance Monoid LlvmAccum where
1844 mempty = LlvmAccum nilOL []
1845 LlvmAccum stmtsA declsA `mappend` LlvmAccum stmtsB declsB =
1846 LlvmAccum (stmtsA `mappend` stmtsB) (declsA `mappend` declsB)
1847
1848 liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
1849 liftExprData action = do
1850 (var, stmts, decls) <- lift action
1851 tell $ LlvmAccum stmts decls
1852 return var
1853
1854 statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()
1855 statement stmt = tell $ LlvmAccum (unitOL stmt) []
1856
1857 doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
1858 doExprW a b = do
1859 (var, stmt) <- lift $ doExpr a b
1860 statement stmt
1861 return var
1862
1863 exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
1864 exprToVarW = liftExprData . exprToVar
1865
1866 runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
1867 runExprData action = do
1868 (var, LlvmAccum stmts decls) <- runWriterT action
1869 return (var, stmts, decls)
1870
1871 runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
1872 runStmtsDecls action = do
1873 LlvmAccum stmts decls <- execWriterT action
1874 return (stmts, decls)
1875
1876 getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
1877 getCmmRegW = lift . getCmmReg
1878
1879 genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar
1880 genLoadW atomic e ty = liftExprData $ genLoad atomic e ty
1881
1882 doTrashStmts :: WriterT LlvmAccum LlvmM ()
1883 doTrashStmts = do
1884 stmts <- lift getTrashStmts
1885 tell $ LlvmAccum stmts mempty