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