Add support for passing SSE vectors in registers.
[ghc.git] / compiler / llvmGen / LlvmCodeGen / CodeGen.hs
1 {-# OPTIONS -fno-warn-type-defaults #-}
2 -- ----------------------------------------------------------------------------
3 -- | Handle conversion of CmmProc to LLVM code.
4 --
5
6 {-# LANGUAGE GADTs #-}
7 module LlvmCodeGen.CodeGen ( genLlvmProc ) where
8
9 #include "HsVersions.h"
10
11 import Llvm
12 import LlvmCodeGen.Base
13 import LlvmCodeGen.Regs
14
15 import BlockId
16 import CodeGen.Platform ( activeStgRegs, callerSaves )
17 import CLabel
18 import Cmm
19 import PprCmm
20 import CmmUtils
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 Data.List ( partition )
35
36 type LlvmStatements = OrdList LlvmStatement
37
38 -- -----------------------------------------------------------------------------
39 -- | Top-level of the LLVM proc Code generator
40 --
41 genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl])
42 genLlvmProc env (CmmProc infos lbl live graph) = do
43 let blocks = toBlockListEntryFirst graph
44 (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], [])
45 let info = mapLookup (g_entry graph) infos
46 proc = CmmProc info lbl live (ListGraph lmblocks)
47 return (env', proc:lmdata)
48
49 genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!"
50
51 -- -----------------------------------------------------------------------------
52 -- * Block code generation
53 --
54
55 -- | Generate code for a list of blocks that make up a complete procedure.
56 basicBlocksCodeGen :: LlvmEnv
57 -> LiveGlobalRegs
58 -> [CmmBlock]
59 -> ( [LlvmBasicBlock] , [LlvmCmmDecl] )
60 -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] )
61 basicBlocksCodeGen env live [] (blocks0, tops0)
62 = return (env, fblocks, tops)
63 where
64 dflags = getDflags env
65 blocks = reverse blocks0
66 tops = reverse tops0
67 (blocks', allocs) = mapAndUnzip dominateAllocs blocks
68 allocs' = concat allocs
69 (BasicBlock id fstmts : rblks) = blocks'
70 fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks
71
72 basicBlocksCodeGen env live (block:blocks) (lblocks, ltops)
73 = do (env', lb, lt) <- basicBlockCodeGen env block
74 basicBlocksCodeGen env' live blocks (lb : lblocks, reverse lt ++ ltops)
75
76
77 -- | Allocations need to be extracted so they can be moved to the entry
78 -- of a function to make sure they dominate all possible paths in the CFG.
79 dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
80 dominateAllocs (BasicBlock id stmts)
81 = let (allocs, stmts') = partition isAlloc stmts
82 isAlloc (Assignment _ (Alloca _ _)) = True
83 isAlloc _other = False
84 in (BasicBlock id stmts', allocs)
85
86
87 -- | Generate code for one block
88 basicBlockCodeGen :: LlvmEnv
89 -> CmmBlock
90 -> UniqSM ( LlvmEnv, LlvmBasicBlock, [LlvmCmmDecl] )
91 basicBlockCodeGen env block
92 = do let (CmmEntry id, nodes, tail) = blockSplit block
93 let stmts = blockToList nodes
94 (env', mid_instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
95 (env'', tail_instrs, top') <- stmtToInstrs env' tail
96 let instrs = fromOL (mid_instrs `appOL` tail_instrs)
97 return (env'', BasicBlock id instrs, top' ++ top)
98
99 -- -----------------------------------------------------------------------------
100 -- * CmmNode code generation
101 --
102
103 -- A statement conversion return data.
104 -- * LlvmEnv: The new environment
105 -- * LlvmStatements: The compiled LLVM statements.
106 -- * LlvmCmmDecl: Any global data needed.
107 type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmDecl])
108
109
110 -- | Convert a list of CmmNode's to LlvmStatement's
111 stmtsToInstrs :: LlvmEnv -> [CmmNode e x] -> (LlvmStatements, [LlvmCmmDecl])
112 -> UniqSM StmtData
113 stmtsToInstrs env [] (llvm, top)
114 = return (env, llvm, top)
115
116 stmtsToInstrs env (stmt : stmts) (llvm, top)
117 = do (env', instrs, tops) <- stmtToInstrs env stmt
118 stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops)
119
120
121 -- | Convert a CmmNode to a list of LlvmStatement's
122 stmtToInstrs :: LlvmEnv -> CmmNode e x
123 -> UniqSM StmtData
124 stmtToInstrs env stmt = case stmt of
125
126 CmmComment _ -> return (env, nilOL, []) -- nuke comments
127
128 CmmAssign reg src -> genAssign env reg src
129 CmmStore addr src -> genStore env addr src
130
131 CmmBranch id -> genBranch env id
132 CmmCondBranch arg true false -> genCondBranch env arg true false
133 CmmSwitch arg ids -> genSwitch env arg ids
134
135 -- Foreign Call
136 CmmUnsafeForeignCall target res args -> genCall env target res args
137
138 -- Tail call
139 CmmCall { cml_target = arg,
140 cml_args_regs = live } -> genJump env arg live
141
142 _ -> panic "Llvm.CodeGen.stmtToInstrs"
143
144 -- | Memory barrier instruction for LLVM >= 3.0
145 barrier :: LlvmEnv -> UniqSM StmtData
146 barrier env = do
147 let s = Fence False SyncSeqCst
148 return (env, unitOL s, [])
149
150 -- | Memory barrier instruction for LLVM < 3.0
151 oldBarrier :: LlvmEnv -> UniqSM StmtData
152 oldBarrier env = do
153 let dflags = getDflags env
154 let fname = fsLit "llvm.memory.barrier"
155 let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
156 FixedArgs (tysToParams [i1, i1, i1, i1, i1]) (llvmFunAlign dflags)
157 let fty = LMFunction funSig
158
159 let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False
160 let tops = case funLookup fname env of
161 Just _ -> []
162 Nothing -> [CmmData Data [([],[fty])]]
163
164 let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue]
165 let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs
166 let env' = funInsert fname fty env
167
168 return (env', unitOL s1, tops)
169
170 where
171 lmTrue :: LlvmVar
172 lmTrue = mkIntLit i1 (-1)
173
174 -- | Foreign Calls
175 genCall :: LlvmEnv -> ForeignTarget -> [CmmFormal] -> [CmmActual]
176 -> UniqSM StmtData
177
178 -- Write barrier needs to be handled specially as it is implemented as an LLVM
179 -- intrinsic function.
180 genCall env (PrimTarget MO_WriteBarrier) _ _
181 | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC]
182 = return (env, nilOL, [])
183 | getLlvmVer env > 29 = barrier env
184 | otherwise = oldBarrier env
185
186 genCall env (PrimTarget MO_Touch) _ _
187 = return (env, nilOL, [])
188
189 genCall env (PrimTarget (MO_UF_Conv w)) [dst] [e] = do
190 let (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst)
191 ty = cmmToLlvmType $ localRegType dst
192 width = widthToLlvmFloat w
193 castV <- mkLocalVar ty
194 (env2, ve, stmts2, top2) <- exprToVar env1 e
195 let stmt3 = Assignment castV $ Cast LM_Uitofp ve width
196 stmt4 = Store castV dstV
197 stmts = stmts1 `appOL` stmts2 `snocOL` stmt3 `snocOL` stmt4
198 return (env2, stmts, top1 ++ top2)
199
200 genCall _ (PrimTarget (MO_UF_Conv _)) [_] args =
201 panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
202 "Can only handle 1, given" ++ show (length args) ++ "."
203
204 -- Handle popcnt function specifically since GHC only really has i32 and i64
205 -- types and things like Word8 are backed by an i32 and just present a logical
206 -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM
207 -- is strict about types.
208 genCall env t@(PrimTarget (MO_PopCnt w)) [dst] args = do
209 let dflags = getDflags env
210 width = widthToLlvmInt w
211 dstTy = cmmToLlvmType $ localRegType dst
212 funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible
213 CC_Ccc width FixedArgs (tysToParams [width]) Nothing
214 (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst)
215
216 let (_, arg_hints) = foreignTargetHints t
217 let args_hints = zip args arg_hints
218 (env2, argsV, stmts2, top2) <- arg_vars env1 args_hints ([], nilOL, [])
219 (env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t
220 (argsV', stmts4) <- castVars dflags $ zip argsV [width]
221 (retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
222 ([retV'], stmts5) <- castVars dflags [(retV,dstTy)]
223 let s2 = Store retV' dstV
224
225 let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL`
226 s1 `appOL` stmts5 `snocOL` s2
227 return (env3, stmts, top1 ++ top2 ++ top3)
228
229 -- Handle memcpy function specifically since llvm's intrinsic version takes
230 -- some extra parameters.
231 genCall env t@(PrimTarget op) [] args'
232 | op == MO_Memcpy ||
233 op == MO_Memset ||
234 op == MO_Memmove = do
235 let dflags = getDflags env
236 (args, alignVal) = splitAlignVal args'
237 (isVolTy, isVolVal) = if getLlvmVer env >= 28
238 then ([i1], [mkIntLit i1 0]) else ([], [])
239 argTy | op == MO_Memset = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy
240 | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy
241 funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
242 CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
243
244 let (_, arg_hints) = foreignTargetHints t
245 let args_hints = zip args arg_hints
246 (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, [])
247 (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t
248 (argVars', stmts3) <- castVars dflags $ zip argVars argTy
249
250 let arguments = argVars' ++ (alignVal:isVolVal)
251 call = Expr $ Call StdCall fptr arguments []
252 stmts = stmts1 `appOL` stmts2 `appOL` stmts3
253 `appOL` trashStmts (getDflags env) `snocOL` call
254 return (env2, stmts, top1 ++ top2)
255
256 where
257 splitAlignVal xs = (init xs, extractLit $ last xs)
258
259 -- Fix for trac #6158. Since LLVM 3.1, opt fails when given anything other
260 -- than a direct constant (i.e. 'i32 8') as the alignment argument for the
261 -- memcpy & co llvm intrinsic functions. So we handle this directly now.
262 extractLit (CmmLit (CmmInt i _)) = mkIntLit i32 i
263 extractLit _other = trace ("WARNING: Non constant alignment value given" ++
264 " for memcpy! Please report to GHC developers")
265 mkIntLit i32 0
266
267 -- Handle all other foreign calls and prim ops.
268 genCall env target res args = do
269
270 let dflags = getDflags env
271
272 -- parameter types
273 let arg_type (_, AddrHint) = i8Ptr
274 -- cast pointers to i8*. Llvm equivalent of void*
275 arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr
276
277 -- ret type
278 let ret_type [] = LMVoid
279 ret_type [(_, AddrHint)] = i8Ptr
280 ret_type [(reg, _)] = cmmToLlvmType $ localRegType reg
281 ret_type t = panic $ "genCall: Too many return values! Can only handle"
282 ++ " 0 or 1, given " ++ show (length t) ++ "."
283
284 -- extract Cmm call convention, and translate to LLVM call convention
285 let lmconv = case target of
286 ForeignTarget _ (ForeignConvention conv _ _ _) ->
287 case conv of
288 StdCallConv -> case platformArch (getLlvmPlatform env) of
289 ArchX86 -> CC_X86_Stdcc
290 ArchX86_64 -> CC_X86_Stdcc
291 _ -> CC_Ccc
292 CCallConv -> CC_Ccc
293 CApiConv -> CC_Ccc
294 PrimCallConv -> panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv"
295
296 PrimTarget _ -> CC_Ccc
297
298 {-
299 CC_Ccc of the possibilities here are a worry with the use of a custom
300 calling convention for passing STG args. In practice the more
301 dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
302
303 The native code generator only handles StdCall and CCallConv.
304 -}
305
306 -- call attributes
307 let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs
308 | otherwise = llvmStdFunAttrs
309
310 never_returns = case target of
311 ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True
312 _ -> False
313
314 -- fun type
315 let (res_hints, arg_hints) = foreignTargetHints target
316 let args_hints = zip args arg_hints
317 let ress_hints = zip res res_hints
318 let ccTy = StdCall -- tail calls should be done through CmmJump
319 let retTy = ret_type ress_hints
320 let argTy = tysToParams $ map arg_type args_hints
321 let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
322 lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
323
324
325
326 (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, [])
327 (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target
328
329 let retStmt | ccTy == TailCall = unitOL $ Return Nothing
330 | never_returns = unitOL $ Unreachable
331 | otherwise = nilOL
332
333 let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts (getDflags env)
334
335 -- make the actual call
336 case retTy of
337 LMVoid -> do
338 let s1 = Expr $ Call ccTy fptr argVars fnAttrs
339 let allStmts = stmts `snocOL` s1 `appOL` retStmt
340 return (env2, allStmts, top1 ++ top2)
341
342 _ -> do
343 (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
344 -- get the return register
345 let ret_reg [reg] = reg
346 ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
347 ++ " 1, given " ++ show (length t) ++ "."
348 let creg = ret_reg res
349 let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
350 let allStmts = stmts `snocOL` s1 `appOL` stmts3
351 if retTy == pLower (getVarType vreg)
352 then do
353 let s2 = Store v1 vreg
354 return (env3, allStmts `snocOL` s2 `appOL` retStmt,
355 top1 ++ top2 ++ top3)
356 else do
357 let ty = pLower $ getVarType vreg
358 let op = case ty of
359 vt | isPointer vt -> LM_Bitcast
360 | isInt vt -> LM_Ptrtoint
361 | otherwise ->
362 panic $ "genCall: CmmReg bad match for"
363 ++ " returned type!"
364
365 (v2, s2) <- doExpr ty $ Cast op v1 ty
366 let s3 = Store v2 vreg
367 return (env3, allStmts `snocOL` s2 `snocOL` s3
368 `appOL` retStmt, top1 ++ top2 ++ top3)
369
370
371 -- | Create a function pointer from a target.
372 getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> ForeignTarget
373 -> UniqSM ExprData
374 getFunPtr env funTy targ = case targ of
375 ForeignTarget (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl
376
377 ForeignTarget expr _ -> do
378 (env', v1, stmts, top) <- exprToVar env expr
379 let fty = funTy $ fsLit "dynamic"
380 cast = case getVarType v1 of
381 ty | isPointer ty -> LM_Bitcast
382 ty | isInt ty -> LM_Inttoptr
383
384 ty -> panic $ "genCall: Expr is of bad type for function"
385 ++ " call! (" ++ show (ty) ++ ")"
386
387 (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
388 return (env', v2, stmts `snocOL` s1, top)
389
390 PrimTarget mop -> litCase $ cmmPrimOpFunctions env mop
391
392 where
393 litCase name = do
394 case funLookup name env of
395 Just ty'@(LMFunction sig) -> do
396 -- Function in module in right form
397 let fun = LMGlobalVar name ty' (funcLinkage sig)
398 Nothing Nothing False
399 return (env, fun, nilOL, [])
400
401 Just ty' -> do
402 -- label in module but not function pointer, convert
403 let fty@(LMFunction sig) = funTy name
404 fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
405 Nothing Nothing False
406 (v1, s1) <- doExpr (pLift fty)
407 $ Cast LM_Bitcast fun (pLift fty)
408 return (env, v1, unitOL s1, [])
409
410 Nothing -> do
411 -- label not in module, create external reference
412 let fty@(LMFunction sig) = funTy name
413 fun = LMGlobalVar name fty (funcLinkage sig)
414 Nothing Nothing False
415 top = [CmmData Data [([],[fty])]]
416 env' = funInsert name fty env
417 return (env', fun, nilOL, top)
418
419
420 -- | Conversion of call arguments.
421 arg_vars :: LlvmEnv
422 -> [(CmmActual, ForeignHint)]
423 -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
424 -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmDecl])
425
426 arg_vars env [] (vars, stmts, tops)
427 = return (env, vars, stmts, tops)
428
429 arg_vars env ((e, AddrHint):rest) (vars, stmts, tops)
430 = do (env', v1, stmts', top') <- exprToVar env e
431 let op = case getVarType v1 of
432 ty | isPointer ty -> LM_Bitcast
433 ty | isInt ty -> LM_Inttoptr
434
435 a -> panic $ "genCall: Can't cast llvmType to i8*! ("
436 ++ show a ++ ")"
437
438 (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
439 arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
440 tops ++ top')
441
442 arg_vars env ((e, _):rest) (vars, stmts, tops)
443 = do (env', v1, stmts', top') <- exprToVar env e
444 arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
445
446
447 -- | Cast a collection of LLVM variables to specific types.
448 castVars :: DynFlags -> [(LlvmVar, LlvmType)]
449 -> UniqSM ([LlvmVar], LlvmStatements)
450 castVars dflags vars = do
451 done <- mapM (uncurry (castVar dflags)) vars
452 let (vars', stmts) = unzip done
453 return (vars', toOL stmts)
454
455 -- | Cast an LLVM variable to a specific type, panicing if it can't be done.
456 castVar :: DynFlags -> LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement)
457 castVar dflags v t
458 | getVarType v == t
459 = return (v, Nop)
460
461 | otherwise
462 = let op = case (getVarType v, t) of
463 (LMInt n, LMInt m)
464 -> if n < m then LM_Sext else LM_Trunc
465 (vt, _) | isFloat vt && isFloat t
466 -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t
467 then LM_Fpext else LM_Fptrunc
468 (vt, _) | isInt vt && isFloat t -> LM_Sitofp
469 (vt, _) | isFloat vt && isInt t -> LM_Fptosi
470 (vt, _) | isInt vt && isPointer t -> LM_Inttoptr
471 (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint
472 (vt, _) | isPointer vt && isPointer t -> LM_Bitcast
473 (vt, _) | isVector vt && isVector t -> LM_Bitcast
474
475 (vt, _) -> panic $ "castVars: Can't cast this type ("
476 ++ show vt ++ ") to (" ++ show t ++ ")"
477 in doExpr t $ Cast op v t
478
479
480 -- | Decide what C function to use to implement a CallishMachOp
481 cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString
482 cmmPrimOpFunctions env mop
483 = case mop of
484 MO_F32_Exp -> fsLit "expf"
485 MO_F32_Log -> fsLit "logf"
486 MO_F32_Sqrt -> fsLit "llvm.sqrt.f32"
487 MO_F32_Pwr -> fsLit "llvm.pow.f32"
488
489 MO_F32_Sin -> fsLit "llvm.sin.f32"
490 MO_F32_Cos -> fsLit "llvm.cos.f32"
491 MO_F32_Tan -> fsLit "tanf"
492
493 MO_F32_Asin -> fsLit "asinf"
494 MO_F32_Acos -> fsLit "acosf"
495 MO_F32_Atan -> fsLit "atanf"
496
497 MO_F32_Sinh -> fsLit "sinhf"
498 MO_F32_Cosh -> fsLit "coshf"
499 MO_F32_Tanh -> fsLit "tanhf"
500
501 MO_F64_Exp -> fsLit "exp"
502 MO_F64_Log -> fsLit "log"
503 MO_F64_Sqrt -> fsLit "llvm.sqrt.f64"
504 MO_F64_Pwr -> fsLit "llvm.pow.f64"
505
506 MO_F64_Sin -> fsLit "llvm.sin.f64"
507 MO_F64_Cos -> fsLit "llvm.cos.f64"
508 MO_F64_Tan -> fsLit "tan"
509
510 MO_F64_Asin -> fsLit "asin"
511 MO_F64_Acos -> fsLit "acos"
512 MO_F64_Atan -> fsLit "atan"
513
514 MO_F64_Sinh -> fsLit "sinh"
515 MO_F64_Cosh -> fsLit "cosh"
516 MO_F64_Tanh -> fsLit "tanh"
517
518 MO_Memcpy -> fsLit $ "llvm.memcpy." ++ intrinTy1
519 MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1
520 MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2
521
522 (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w)
523
524 MO_S_QuotRem {} -> unsupported
525 MO_U_QuotRem {} -> unsupported
526 MO_U_QuotRem2 {} -> unsupported
527 MO_Add2 {} -> unsupported
528 MO_U_Mul2 {} -> unsupported
529 MO_WriteBarrier -> unsupported
530 MO_Touch -> unsupported
531 MO_UF_Conv _ -> unsupported
532
533 where
534 dflags = getDflags env
535 intrinTy1 = (if getLlvmVer env >= 28
536 then "p0i8.p0i8." else "") ++ show (llvmWord dflags)
537 intrinTy2 = (if getLlvmVer env >= 28
538 then "p0i8." else "") ++ show (llvmWord dflags)
539 unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
540 ++ " not supported here")
541
542 -- | Tail function calls
543 genJump :: LlvmEnv -> CmmExpr -> [GlobalReg] -> UniqSM StmtData
544
545 -- Call to known function
546 genJump env (CmmLit (CmmLabel lbl)) live = do
547 (env', vf, stmts, top) <- getHsFunc env live lbl
548 (stgRegs, stgStmts) <- funEpilogue env live
549 let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
550 let s2 = Return Nothing
551 return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
552
553
554 -- Call to unknown function / address
555 genJump env expr live = do
556 let fty = llvmFunTy (getDflags env) live
557 (env', vf, stmts, top) <- exprToVar env expr
558
559 let cast = case getVarType vf of
560 ty | isPointer ty -> LM_Bitcast
561 ty | isInt ty -> LM_Inttoptr
562
563 ty -> panic $ "genJump: Expr is of bad type for function call! ("
564 ++ show (ty) ++ ")"
565
566 (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
567 (stgRegs, stgStmts) <- funEpilogue env live
568 let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
569 let s3 = Return Nothing
570 return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
571 top)
572
573
574 -- | CmmAssign operation
575 --
576 -- We use stack allocated variables for CmmReg. The optimiser will replace
577 -- these with registers when possible.
578 genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData
579 genAssign env reg val = do
580 let dflags = getDflags env
581 (env1, vreg, stmts1, top1) = getCmmReg env reg
582 (env2, vval, stmts2, top2) <- exprToVar env1 val
583 let stmts = stmts1 `appOL` stmts2
584
585 let ty = (pLower . getVarType) vreg
586 case ty of
587 -- Some registers are pointer types, so need to cast value to pointer
588 LMPointer _ | getVarType vval == llvmWord dflags -> do
589 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
590 let s2 = Store v vreg
591 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
592
593 LMVector _ _ -> do
594 (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty
595 let s2 = Store v vreg
596 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
597
598 _ -> do
599 let s1 = Store vval vreg
600 return (env2, stmts `snocOL` s1, top1 ++ top2)
601
602
603 -- | CmmStore operation
604 genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
605
606 -- First we try to detect a few common cases and produce better code for
607 -- these then the default case. We are mostly trying to detect Cmm code
608 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
609 -- generic case that uses casts and pointer arithmetic
610 genStore env addr@(CmmReg (CmmGlobal r)) val
611 = genStore_fast env addr r 0 val
612
613 genStore env addr@(CmmRegOff (CmmGlobal r) n) val
614 = genStore_fast env addr r n val
615
616 genStore env addr@(CmmMachOp (MO_Add _) [
617 (CmmReg (CmmGlobal r)),
618 (CmmLit (CmmInt n _))])
619 val
620 = genStore_fast env addr r (fromInteger n) val
621
622 genStore env addr@(CmmMachOp (MO_Sub _) [
623 (CmmReg (CmmGlobal r)),
624 (CmmLit (CmmInt n _))])
625 val
626 = genStore_fast env addr r (negate $ fromInteger n) val
627
628 -- generic case
629 genStore env addr val = genStore_slow env addr val [other]
630
631 -- | CmmStore operation
632 -- This is a special case for storing to a global register pointer
633 -- offset such as I32[Sp+8].
634 genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr
635 -> UniqSM StmtData
636 genStore_fast env addr r n val
637 = let dflags = getDflags env
638 gr = lmGlobalRegVar (getDflags env) r
639 meta = [getTBAA r]
640 grt = (pLower . getVarType) gr
641 (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
642 in case isPointer grt && rem == 0 of
643 True -> do
644 (env', vval, stmts, top) <- exprToVar env val
645 (gv, s1) <- doExpr grt $ Load gr
646 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
647 -- We might need a different pointer type, so check
648 case pLower grt == getVarType vval of
649 -- were fine
650 True -> do
651 let s3 = MetaStmt meta $ Store vval ptr
652 return (env', stmts `snocOL` s1 `snocOL` s2
653 `snocOL` s3, top)
654
655 -- cast to pointer type needed
656 False -> do
657 let ty = (pLift . getVarType) vval
658 (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
659 let s4 = MetaStmt meta $ Store vval ptr'
660 return (env', stmts `snocOL` s1 `snocOL` s2
661 `snocOL` s3 `snocOL` s4, top)
662
663 -- If its a bit type then we use the slow method since
664 -- we can't avoid casting anyway.
665 False -> genStore_slow env addr val meta
666
667
668 -- | CmmStore operation
669 -- Generic case. Uses casts and pointer arithmetic if needed.
670 genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData
671 genStore_slow env addr val meta = do
672 (env1, vaddr, stmts1, top1) <- exprToVar env addr
673 (env2, vval, stmts2, top2) <- exprToVar env1 val
674
675 let stmts = stmts1 `appOL` stmts2
676 case getVarType vaddr of
677 -- sometimes we need to cast an int to a pointer before storing
678 LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do
679 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
680 let s2 = MetaStmt meta $ Store v vaddr
681 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
682
683 LMPointer _ -> do
684 let s1 = MetaStmt meta $ Store vval vaddr
685 return (env2, stmts `snocOL` s1, top1 ++ top2)
686
687 i@(LMInt _) | i == llvmWord dflags -> do
688 let vty = pLift $ getVarType vval
689 (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
690 let s2 = MetaStmt meta $ Store vval vptr
691 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
692
693 other ->
694 pprPanic "genStore: ptr not right type!"
695 (PprCmm.pprExpr addr <+> text (
696 "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
697 ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
698 ", Var: " ++ show vaddr))
699 where dflags = getDflags env
700
701
702 -- | Unconditional branch
703 genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData
704 genBranch env id =
705 let label = blockIdToLlvm id
706 in return (env, unitOL $ Branch label, [])
707
708
709 -- | Conditional branch
710 genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData
711 genCondBranch env cond idT idF = do
712 let labelT = blockIdToLlvm idT
713 let labelF = blockIdToLlvm idF
714 -- See Note [Literals and branch conditions].
715 (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
716 if getVarType vc == i1
717 then do
718 let s1 = BranchIf vc labelT labelF
719 return $ (env', stmts `snocOL` s1, top)
720 else
721 panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
722
723 {- Note [Literals and branch conditions]
724 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
725
726 It is important that whenever we generate branch conditions for
727 literals like '1', they are properly narrowed to an LLVM expression of
728 type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
729 a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
730 must be certain to return a properly narrowed type. genLit is
731 responsible for this, in the case of literal integers.
732
733 Often, we won't see direct statements like:
734
735 if(1) {
736 ...
737 } else {
738 ...
739 }
740
741 at this point in the pipeline, because the Glorious Code Generator
742 will do trivial branch elimination in the sinking pass (among others,)
743 which will eliminate the expression entirely.
744
745 However, it's certainly possible and reasonable for this to occur in
746 hand-written C-- code. Consider something like:
747
748 #ifndef SOME_CONDITIONAL
749 #define CHECK_THING(x) 1
750 #else
751 #define CHECK_THING(x) some_operation((x))
752 #endif
753
754 f() {
755
756 if (CHECK_THING(xyz)) {
757 ...
758 } else {
759 ...
760 }
761
762 }
763
764 In such an instance, CHECK_THING might result in an *expression* in
765 one case, and a *literal* in the other, depending on what in
766 particular was #define'd. So we must be sure to properly narrow the
767 literal in this case to i1 as it won't be eliminated beforehand.
768
769 For a real example of this, see ./rts/StgStdThunks.cmm
770
771 -}
772
773
774
775 -- | Switch branch
776 --
777 -- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
778 -- However, they may be defined one day, so we better document this behaviour.
779 genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
780 genSwitch env cond maybe_ids = do
781 (env', vc, stmts, top) <- exprToVar env cond
782 let ty = getVarType vc
783
784 let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ]
785 let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
786 -- out of range is undefied, so lets just branch to first label
787 let (_, defLbl) = head labels
788
789 let s1 = Switch vc defLbl labels
790 return $ (env', stmts `snocOL` s1, top)
791
792
793 -- -----------------------------------------------------------------------------
794 -- * CmmExpr code generation
795 --
796
797 -- | An expression conversion return data:
798 -- * LlvmEnv: The new enviornment
799 -- * LlvmVar: The var holding the result of the expression
800 -- * LlvmStatements: Any statements needed to evaluate the expression
801 -- * LlvmCmmDecl: Any global data needed for this expression
802 type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmDecl])
803
804 -- | Values which can be passed to 'exprToVar' to configure its
805 -- behaviour in certain circumstances.
806 --
807 -- Currently just used for determining if a comparison should return
808 -- a boolean (i1) or a word. See Note [Literals and branch conditions].
809 newtype EOption = EOption { i1Expected :: Bool }
810 -- XXX: EOption is an ugly and inefficient solution to this problem.
811
812 -- | i1 type expected (condition scrutinee).
813 i1Option :: EOption
814 i1Option = EOption True
815
816 -- | Word type expected (usual).
817 wordOption :: EOption
818 wordOption = EOption False
819
820 -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
821 -- expression being stored in the returned LlvmVar.
822 exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
823 exprToVar env = exprToVarOpt env wordOption
824
825 exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
826 exprToVarOpt env opt e = case e of
827
828 CmmLit lit
829 -> genLit opt env lit
830
831 CmmLoad e' ty
832 -> genLoad env e' ty
833
834 -- Cmmreg in expression is the value, so must load. If you want actual
835 -- reg pointer, call getCmmReg directly.
836 CmmReg r -> do
837 let (env', vreg, stmts, top) = getCmmReg env r
838 (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg
839 case (isPointer . getVarType) v1 of
840 True -> do
841 -- Cmm wants the value, so pointer types must be cast to ints
842 (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)
843 return (env', v2, stmts `snocOL` s1 `snocOL` s2, top)
844
845 False -> return (env', v1, stmts `snocOL` s1, top)
846
847 CmmMachOp op exprs
848 -> genMachOp env opt op exprs
849
850 CmmRegOff r i
851 -> exprToVar env $ expandCmmReg dflags (r, i)
852
853 CmmStackSlot _ _
854 -> panic "exprToVar: CmmStackSlot not supported!"
855
856 where dflags = getDflags env
857
858 -- | Handle CmmMachOp expressions
859 genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
860
861 -- Unary Machop
862 genMachOp env _ op [x] = case op of
863
864 MO_Not w ->
865 let all1 = mkIntLit (widthToLlvmInt w) (-1)
866 in negate (widthToLlvmInt w) all1 LM_MO_Xor
867
868 MO_S_Neg w ->
869 let all0 = mkIntLit (widthToLlvmInt w) 0
870 in negate (widthToLlvmInt w) all0 LM_MO_Sub
871
872 MO_F_Neg w ->
873 let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
874 in negate (widthToLlvmFloat w) all0 LM_MO_FSub
875
876 MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
877 MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
878
879 MO_SS_Conv from to
880 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
881
882 MO_UU_Conv from to
883 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
884
885 MO_FF_Conv from to
886 -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
887
888 MO_VS_Neg len w ->
889 let ty = widthToLlvmInt w
890 vecty = LMVector len ty
891 all0 = LMIntLit (-0) ty
892 all0s = LMLitVar $ LMVectorLit (replicate len all0)
893 in negateVec vecty all0s LM_MO_Sub
894
895 MO_VF_Neg len w ->
896 let ty = widthToLlvmFloat w
897 vecty = LMVector len ty
898 all0 = LMFloatLit (-0) ty
899 all0s = LMLitVar $ LMVectorLit (replicate len all0)
900 in negateVec vecty all0s LM_MO_FSub
901
902 -- Handle unsupported cases explicitly so we get a warning
903 -- of missing case when new MachOps added
904 MO_Add _ -> panicOp
905 MO_Mul _ -> panicOp
906 MO_Sub _ -> panicOp
907 MO_S_MulMayOflo _ -> panicOp
908 MO_S_Quot _ -> panicOp
909 MO_S_Rem _ -> panicOp
910 MO_U_MulMayOflo _ -> panicOp
911 MO_U_Quot _ -> panicOp
912 MO_U_Rem _ -> panicOp
913
914 MO_Eq _ -> panicOp
915 MO_Ne _ -> panicOp
916 MO_S_Ge _ -> panicOp
917 MO_S_Gt _ -> panicOp
918 MO_S_Le _ -> panicOp
919 MO_S_Lt _ -> panicOp
920 MO_U_Ge _ -> panicOp
921 MO_U_Gt _ -> panicOp
922 MO_U_Le _ -> panicOp
923 MO_U_Lt _ -> panicOp
924
925 MO_F_Add _ -> panicOp
926 MO_F_Sub _ -> panicOp
927 MO_F_Mul _ -> panicOp
928 MO_F_Quot _ -> panicOp
929 MO_F_Eq _ -> panicOp
930 MO_F_Ne _ -> panicOp
931 MO_F_Ge _ -> panicOp
932 MO_F_Gt _ -> panicOp
933 MO_F_Le _ -> panicOp
934 MO_F_Lt _ -> panicOp
935
936 MO_And _ -> panicOp
937 MO_Or _ -> panicOp
938 MO_Xor _ -> panicOp
939 MO_Shl _ -> panicOp
940 MO_U_Shr _ -> panicOp
941 MO_S_Shr _ -> panicOp
942
943 MO_V_Insert _ _ -> panicOp
944 MO_V_Extract _ _ -> panicOp
945
946 MO_V_Add _ _ -> panicOp
947 MO_V_Sub _ _ -> panicOp
948 MO_V_Mul _ _ -> panicOp
949
950 MO_VS_Quot _ _ -> panicOp
951 MO_VS_Rem _ _ -> panicOp
952
953 MO_VF_Insert _ _ -> panicOp
954 MO_VF_Extract _ _ -> panicOp
955
956 MO_VF_Add _ _ -> panicOp
957 MO_VF_Sub _ _ -> panicOp
958 MO_VF_Mul _ _ -> panicOp
959 MO_VF_Quot _ _ -> panicOp
960
961 where
962 dflags = getDflags env
963
964 negate ty v2 negOp = do
965 (env', vx, stmts, top) <- exprToVar env x
966 (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
967 return (env', v1, stmts `snocOL` s1, top)
968
969 negateVec ty v2 negOp = do
970 (env', vx, stmts1, top) <- exprToVar env x
971 ([vx'], stmts2) <- castVars dflags [(vx, ty)]
972 (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
973 return (env', v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
974
975 fiConv ty convOp = do
976 (env', vx, stmts, top) <- exprToVar env x
977 (v1, s1) <- doExpr ty $ Cast convOp vx ty
978 return (env', v1, stmts `snocOL` s1, top)
979
980 sameConv from ty reduce expand = do
981 x'@(env', vx, stmts, top) <- exprToVar env x
982 let sameConv' op = do
983 (v1, s1) <- doExpr ty $ Cast op vx ty
984 return (env', v1, stmts `snocOL` s1, top)
985 let toWidth = llvmWidthInBits dflags ty
986 -- LLVM doesn't like trying to convert to same width, so
987 -- need to check for that as we do get Cmm code doing it.
988 case widthInBits from of
989 w | w < toWidth -> sameConv' expand
990 w | w > toWidth -> sameConv' reduce
991 _w -> return x'
992
993 panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encourntered"
994 ++ "with one argument! (" ++ show op ++ ")"
995
996 -- Handle GlobalRegs pointers
997 genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
998 = genMachOp_fast env opt o r (fromInteger n) e
999
1000 genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
1001 = genMachOp_fast env opt o r (negate . fromInteger $ n) e
1002
1003 -- Generic case
1004 genMachOp env opt op e = genMachOp_slow env opt op e
1005
1006
1007 -- | Handle CmmMachOp expressions
1008 -- This is a specialised method that handles Global register manipulations like
1009 -- 'Sp - 16', using the getelementptr instruction.
1010 genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
1011 -> UniqSM ExprData
1012 genMachOp_fast env opt op r n e
1013 = let dflags = getDflags env
1014 gr = lmGlobalRegVar dflags r
1015 grt = (pLower . getVarType) gr
1016 (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
1017 in case isPointer grt && rem == 0 of
1018 True -> do
1019 (gv, s1) <- doExpr grt $ Load gr
1020 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
1021 (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)
1022 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])
1023
1024 False -> genMachOp_slow env opt op e
1025
1026
1027 -- | Handle CmmMachOp expressions
1028 -- This handles all the cases not handle by the specialised genMachOp_fast.
1029 genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
1030
1031 -- Element extraction
1032 genMachOp_slow env _ (MO_V_Extract l w) [val, idx] = do
1033 (env1, vval, stmts1, top1) <- exprToVar env val
1034 (env2, vidx, stmts2, top2) <- exprToVar env1 idx
1035 ([vval'], stmts3) <- castVars dflags [(vval, LMVector l ty)]
1036 (v1, s1) <- doExpr ty $ Extract vval' vidx
1037 return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2)
1038 where
1039 dflags = getDflags env
1040 ty = widthToLlvmInt w
1041
1042 genMachOp_slow env _ (MO_VF_Extract l w) [val, idx] = do
1043 (env1, vval, stmts1, top1) <- exprToVar env val
1044 (env2, vidx, stmts2, top2) <- exprToVar env1 idx
1045 ([vval'], stmts3) <- castVars dflags [(vval, LMVector l ty)]
1046 (v1, s1) <- doExpr ty $ Extract vval' vidx
1047 return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2)
1048 where
1049 dflags = getDflags env
1050 ty = widthToLlvmFloat w
1051
1052 -- Element insertion
1053 genMachOp_slow env _ (MO_V_Insert l w) [val, elt, idx] = do
1054 (env1, vval, stmts1, top1) <- exprToVar env val
1055 (env2, velt, stmts2, top2) <- exprToVar env1 elt
1056 (env3, vidx, stmts3, top3) <- exprToVar env2 idx
1057 ([vval'], stmts4) <- castVars dflags [(vval, ty)]
1058 (v1, s1) <- doExpr ty $ Insert vval' velt vidx
1059 return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1,
1060 top1 ++ top2 ++ top3)
1061 where
1062 dflags = getDflags env
1063 ty = LMVector l (widthToLlvmInt w)
1064
1065 genMachOp_slow env _ (MO_VF_Insert l w) [val, elt, idx] = do
1066 (env1, vval, stmts1, top1) <- exprToVar env val
1067 (env2, velt, stmts2, top2) <- exprToVar env1 elt
1068 (env3, vidx, stmts3, top3) <- exprToVar env2 idx
1069 ([vval'], stmts4) <- castVars dflags [(vval, ty)]
1070 (v1, s1) <- doExpr ty $ Insert vval' velt vidx
1071 return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1,
1072 top1 ++ top2 ++ top3)
1073 where
1074 dflags = getDflags env
1075 ty = LMVector l (widthToLlvmFloat w)
1076
1077 -- Binary MachOp
1078 genMachOp_slow env opt op [x, y] = case op of
1079
1080 MO_Eq _ -> genBinComp opt LM_CMP_Eq
1081 MO_Ne _ -> genBinComp opt LM_CMP_Ne
1082
1083 MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
1084 MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
1085 MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
1086 MO_S_Le _ -> genBinComp opt LM_CMP_Sle
1087
1088 MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
1089 MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
1090 MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
1091 MO_U_Le _ -> genBinComp opt LM_CMP_Ule
1092
1093 MO_Add _ -> genBinMach LM_MO_Add
1094 MO_Sub _ -> genBinMach LM_MO_Sub
1095 MO_Mul _ -> genBinMach LM_MO_Mul
1096
1097 MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
1098
1099 MO_S_MulMayOflo w -> isSMulOK w x y
1100
1101 MO_S_Quot _ -> genBinMach LM_MO_SDiv
1102 MO_S_Rem _ -> genBinMach LM_MO_SRem
1103
1104 MO_U_Quot _ -> genBinMach LM_MO_UDiv
1105 MO_U_Rem _ -> genBinMach LM_MO_URem
1106
1107 MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
1108 MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
1109 MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
1110 MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
1111 MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
1112 MO_F_Le _ -> genBinComp opt LM_CMP_Fle
1113
1114 MO_F_Add _ -> genBinMach LM_MO_FAdd
1115 MO_F_Sub _ -> genBinMach LM_MO_FSub
1116 MO_F_Mul _ -> genBinMach LM_MO_FMul
1117 MO_F_Quot _ -> genBinMach LM_MO_FDiv
1118
1119 MO_And _ -> genBinMach LM_MO_And
1120 MO_Or _ -> genBinMach LM_MO_Or
1121 MO_Xor _ -> genBinMach LM_MO_Xor
1122 MO_Shl _ -> genBinMach LM_MO_Shl
1123 MO_U_Shr _ -> genBinMach LM_MO_LShr
1124 MO_S_Shr _ -> genBinMach LM_MO_AShr
1125
1126 MO_V_Add l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add
1127 MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub
1128 MO_V_Mul l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul
1129
1130 MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv
1131 MO_VS_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem
1132
1133 MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd
1134 MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub
1135 MO_VF_Mul l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul
1136 MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv
1137
1138 MO_Not _ -> panicOp
1139 MO_S_Neg _ -> panicOp
1140 MO_F_Neg _ -> panicOp
1141
1142 MO_SF_Conv _ _ -> panicOp
1143 MO_FS_Conv _ _ -> panicOp
1144 MO_SS_Conv _ _ -> panicOp
1145 MO_UU_Conv _ _ -> panicOp
1146 MO_FF_Conv _ _ -> panicOp
1147
1148 MO_V_Insert {} -> panicOp
1149 MO_V_Extract {} -> panicOp
1150
1151 MO_VS_Neg {} -> panicOp
1152
1153 MO_VF_Insert {} -> panicOp
1154 MO_VF_Extract {} -> panicOp
1155
1156 MO_VF_Neg {} -> panicOp
1157
1158 where
1159 dflags = getDflags env
1160
1161 binLlvmOp ty binOp = do
1162 (env1, vx, stmts1, top1) <- exprToVar env x
1163 (env2, vy, stmts2, top2) <- exprToVar env1 y
1164 if getVarType vx == getVarType vy
1165 then do
1166 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
1167 return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1,
1168 top1 ++ top2)
1169
1170 else do
1171 -- Error. Continue anyway so we can debug the generated ll file.
1172 let dflags = getDflags env
1173 style = mkCodeStyle CStyle
1174 toString doc = renderWithStyle dflags doc style
1175 cmmToStr = (lines . toString . PprCmm.pprExpr)
1176 let dx = Comment $ map fsLit $ cmmToStr x
1177 let dy = Comment $ map fsLit $ cmmToStr y
1178 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
1179 let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
1180 `snocOL` dy `snocOL` s1
1181 return (env2, v1, allStmts, top1 ++ top2)
1182
1183 binCastLlvmOp ty binOp = do
1184 (env1, vx, stmts1, top1) <- exprToVar env x
1185 (env2, vy, stmts2, top2) <- exprToVar env1 y
1186 ([vx', vy'], stmts3) <- castVars dflags [(vx, ty), (vy, ty)]
1187 (v1, s1) <- doExpr ty $ binOp vx' vy'
1188 return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1,
1189 top1 ++ top2)
1190
1191 -- | Need to use EOption here as Cmm expects word size results from
1192 -- comparisons while LLVM return i1. Need to extend to llvmWord type
1193 -- if expected. See Note [Literals and branch conditions].
1194 genBinComp opt cmp = do
1195 ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
1196 if getVarType v1 == i1
1197 then case i1Expected opt of
1198 True -> return ed
1199 False -> do
1200 let w_ = llvmWord dflags
1201 (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
1202 return (env', v2, stmts `snocOL` s1, top)
1203 else
1204 panic $ "genBinComp: Compare returned type other then i1! "
1205 ++ (show $ getVarType v1)
1206
1207 genBinMach op = binLlvmOp getVarType (LlvmOp op)
1208
1209 genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)
1210
1211 -- | Detect if overflow will occur in signed multiply of the two
1212 -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
1213 -- implementation. Its much longer due to type information/safety.
1214 -- This should actually compile to only about 3 asm instructions.
1215 isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData
1216 isSMulOK _ x y = do
1217 (env1, vx, stmts1, top1) <- exprToVar env x
1218 (env2, vy, stmts2, top2) <- exprToVar env1 y
1219
1220 let word = getVarType vx
1221 let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
1222 let shift = llvmWidthInBits dflags word
1223 let shift1 = toIWord dflags (shift - 1)
1224 let shift2 = toIWord dflags shift
1225
1226 if isInt word
1227 then do
1228 (x1, s1) <- doExpr word2 $ Cast LM_Sext vx word2
1229 (y1, s2) <- doExpr word2 $ Cast LM_Sext vy word2
1230 (r1, s3) <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
1231 (rlow1, s4) <- doExpr word $ Cast LM_Trunc r1 word
1232 (rlow2, s5) <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
1233 (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
1234 (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
1235 (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
1236 let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
1237 `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
1238 return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts,
1239 top1 ++ top2)
1240
1241 else
1242 panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"
1243
1244 panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encourntered"
1245 ++ "with two arguments! (" ++ show op ++ ")"
1246
1247 -- More then two expression, invalid!
1248 genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
1249
1250
1251 -- | Handle CmmLoad expression.
1252 genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
1253
1254 -- First we try to detect a few common cases and produce better code for
1255 -- these then the default case. We are mostly trying to detect Cmm code
1256 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
1257 -- generic case that uses casts and pointer arithmetic
1258 genLoad env e@(CmmReg (CmmGlobal r)) ty
1259 = genLoad_fast env e r 0 ty
1260
1261 genLoad env e@(CmmRegOff (CmmGlobal r) n) ty
1262 = genLoad_fast env e r n ty
1263
1264 genLoad env e@(CmmMachOp (MO_Add _) [
1265 (CmmReg (CmmGlobal r)),
1266 (CmmLit (CmmInt n _))])
1267 ty
1268 = genLoad_fast env e r (fromInteger n) ty
1269
1270 genLoad env e@(CmmMachOp (MO_Sub _) [
1271 (CmmReg (CmmGlobal r)),
1272 (CmmLit (CmmInt n _))])
1273 ty
1274 = genLoad_fast env e r (negate $ fromInteger n) ty
1275
1276 -- generic case
1277 genLoad env e ty = genLoad_slow env e ty [other]
1278
1279 -- | Handle CmmLoad expression.
1280 -- This is a special case for loading from a global register pointer
1281 -- offset such as I32[Sp+8].
1282 genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
1283 -> UniqSM ExprData
1284 genLoad_fast env e r n ty =
1285 let dflags = getDflags env
1286 gr = lmGlobalRegVar dflags r
1287 meta = [getTBAA r]
1288 grt = (pLower . getVarType) gr
1289 ty' = cmmToLlvmType ty
1290 (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
1291 in case isPointer grt && rem == 0 of
1292 True -> do
1293 (gv, s1) <- doExpr grt $ Load gr
1294 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
1295 -- We might need a different pointer type, so check
1296 case grt == ty' of
1297 -- were fine
1298 True -> do
1299 (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr)
1300 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3,
1301 [])
1302
1303 -- cast to pointer type needed
1304 False -> do
1305 let pty = pLift ty'
1306 (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
1307 (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr')
1308 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3
1309 `snocOL` s4, [])
1310
1311 -- If its a bit type then we use the slow method since
1312 -- we can't avoid casting anyway.
1313 False -> genLoad_slow env e ty meta
1314
1315
1316 -- | Handle Cmm load expression.
1317 -- Generic case. Uses casts and pointer arithmetic if needed.
1318 genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData
1319 genLoad_slow env e ty meta = do
1320 (env', iptr, stmts, tops) <- exprToVar env e
1321 case getVarType iptr of
1322 LMPointer _ -> do
1323 (dvar, load) <- doExpr (cmmToLlvmType ty)
1324 (MetaExpr meta $ Load iptr)
1325 return (env', dvar, stmts `snocOL` load, tops)
1326
1327 i@(LMInt _) | i == llvmWord dflags -> do
1328 let pty = LMPointer $ cmmToLlvmType ty
1329 (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty
1330 (dvar, load) <- doExpr (cmmToLlvmType ty)
1331 (MetaExpr meta $ Load ptr)
1332 return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
1333
1334 other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
1335 (PprCmm.pprExpr e <+> text (
1336 "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
1337 ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
1338 ", Var: " ++ show iptr))
1339 where dflags = getDflags env
1340
1341 -- | Handle CmmReg expression
1342 --
1343 -- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an
1344 -- equivalent SSA form and avoids having to deal with Phi node insertion.
1345 -- This is also the approach recommended by LLVM developers.
1346 getCmmReg :: LlvmEnv -> CmmReg -> ExprData
1347 getCmmReg env r@(CmmLocal (LocalReg un _))
1348 = let exists = varLookup un env
1349 (newv, stmts) = allocReg r
1350 nenv = varInsert un (pLower $ getVarType newv) env
1351 in case exists of
1352 Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, [])
1353 Nothing -> (nenv, newv, stmts, [])
1354
1355 getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar (getDflags env) g, nilOL, [])
1356
1357
1358 -- | Allocate a CmmReg on the stack
1359 allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
1360 allocReg (CmmLocal (LocalReg un ty))
1361 = let ty' = cmmToLlvmType ty
1362 var = LMLocalVar un (LMPointer ty')
1363 alc = Alloca ty' 1
1364 in (var, unitOL $ Assignment var alc)
1365
1366 allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
1367 ++ " have been handled elsewhere!"
1368
1369
1370 -- | Generate code for a literal
1371 genLit :: EOption -> LlvmEnv -> CmmLit -> UniqSM ExprData
1372 genLit opt env (CmmInt i w)
1373 -- See Note [Literals and branch conditions].
1374 = let width | i1Expected opt = i1
1375 | otherwise = LMInt (widthInBits w)
1376 -- comm = Comment [ fsLit $ "EOption: " ++ show opt
1377 -- , fsLit $ "Width : " ++ show w
1378 -- , fsLit $ "Width' : " ++ show (widthInBits w)
1379 -- ]
1380 in return (env, mkIntLit width i, nilOL, [])
1381
1382 genLit _ env (CmmFloat r w)
1383 = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
1384 nilOL, [])
1385
1386 genLit opt env (CmmVec ls)
1387 = do llvmLits <- mapM toLlvmLit ls
1388 return (env, LMLitVar $ LMVectorLit llvmLits, nilOL, [])
1389 where
1390 toLlvmLit :: CmmLit -> UniqSM LlvmLit
1391 toLlvmLit lit = do
1392 (_, llvmLitVar, _, _) <- genLit opt env lit
1393 case llvmLitVar of
1394 LMLitVar llvmLit -> return llvmLit
1395 _ -> panic "genLit"
1396
1397 genLit _ env cmm@(CmmLabel l)
1398 = let dflags = getDflags env
1399 label = strCLabel_llvm env l
1400 ty = funLookup label env
1401 lmty = cmmToLlvmType $ cmmLitType dflags cmm
1402 in case ty of
1403 -- Make generic external label definition and then pointer to it
1404 Nothing -> do
1405 let glob@(var, _) = genStringLabelRef dflags label
1406 let ldata = [CmmData Data [([glob], [])]]
1407 let env' = funInsert label (pLower $ getVarType var) env
1408 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
1409 return (env', v1, unitOL s1, ldata)
1410
1411 -- Referenced data exists in this module, retrieve type and make
1412 -- pointer to it.
1413 Just ty' -> do
1414 let var = LMGlobalVar label (LMPointer ty')
1415 ExternallyVisible Nothing Nothing False
1416 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
1417 return (env, v1, unitOL s1, [])
1418
1419 genLit opt env (CmmLabelOff label off) = do
1420 let dflags = getDflags env
1421 (env', vlbl, stmts, stat) <- genLit opt env (CmmLabel label)
1422 let voff = toIWord dflags off
1423 (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
1424 return (env', v1, stmts `snocOL` s1, stat)
1425
1426 genLit opt env (CmmLabelDiffOff l1 l2 off) = do
1427 let dflags = getDflags env
1428 (env1, vl1, stmts1, stat1) <- genLit opt env (CmmLabel l1)
1429 (env2, vl2, stmts2, stat2) <- genLit opt env1 (CmmLabel l2)
1430 let voff = toIWord dflags off
1431 let ty1 = getVarType vl1
1432 let ty2 = getVarType vl2
1433 if (isInt ty1) && (isInt ty2)
1434 && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)
1435
1436 then do
1437 (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
1438 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
1439 return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
1440 stat1 ++ stat2)
1441
1442 else
1443 panic "genLit: CmmLabelDiffOff encountered with different label ty!"
1444
1445 genLit opt env (CmmBlock b)
1446 = genLit opt env (CmmLabel $ infoTblLbl b)
1447
1448 genLit _ _ CmmHighStackMark
1449 = panic "genStaticLit - CmmHighStackMark unsupported!"
1450
1451
1452 -- -----------------------------------------------------------------------------
1453 -- * Misc
1454 --
1455
1456 -- | Function prologue. Load STG arguments into variables for function.
1457 funPrologue :: DynFlags -> LiveGlobalRegs -> [LlvmStatement]
1458 funPrologue dflags live = concat $ map getReg $ activeStgRegs platform
1459 where platform = targetPlatform dflags
1460 isLive r = r `elem` alwaysLive || r `elem` live
1461 getReg rr =
1462 let reg = lmGlobalRegVar dflags rr
1463 arg = lmGlobalRegArg dflags rr
1464 ty = (pLower . getVarType) reg
1465 trash = LMLitVar $ LMUndefLit ty
1466 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
1467 in
1468 if isLive rr
1469 then [alloc, Store arg reg]
1470 else [alloc, Store trash reg]
1471
1472
1473 -- | Function epilogue. Load STG variables to use as argument for call.
1474 -- STG Liveness optimisation done here.
1475 funEpilogue :: LlvmEnv -> LiveGlobalRegs -> UniqSM ([LlvmVar], LlvmStatements)
1476
1477 -- Have information and liveness optimisation is enabled
1478 funEpilogue env live = do
1479 loads <- mapM loadExpr (filter isPassed (activeStgRegs platform))
1480 let (vars, stmts) = unzip loads
1481 return (vars, concatOL stmts)
1482 where
1483 dflags = getDflags env
1484 platform = targetPlatform dflags
1485 isLive r = r `elem` alwaysLive || r `elem` live
1486 isPassed r = not (isSSE r) || isLive r
1487 isSSE (FloatReg _) = True
1488 isSSE (DoubleReg _) = True
1489 isSSE (XmmReg _) = True
1490 isSSE _ = False
1491 loadExpr r | isLive r = do
1492 let reg = lmGlobalRegVar dflags r
1493 (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
1494 return (v, unitOL s)
1495 loadExpr r = do
1496 let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
1497 return (LMLitVar $ LMUndefLit ty, unitOL Nop)
1498
1499
1500 -- | A serries of statements to trash all the STG registers.
1501 --
1502 -- In LLVM we pass the STG registers around everywhere in function calls.
1503 -- So this means LLVM considers them live across the entire function, when
1504 -- in reality they usually aren't. For Caller save registers across C calls
1505 -- the saving and restoring of them is done by the Cmm code generator,
1506 -- using Cmm local vars. So to stop LLVM saving them as well (and saving
1507 -- all of them since it thinks they're always live, we trash them just
1508 -- before the call by assigning the 'undef' value to them. The ones we
1509 -- need are restored from the Cmm local var and the ones we don't need
1510 -- are fine to be trashed.
1511 trashStmts :: DynFlags -> LlvmStatements
1512 trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform
1513 where platform = targetPlatform dflags
1514 trashReg r =
1515 let reg = lmGlobalRegVar dflags r
1516 ty = (pLower . getVarType) reg
1517 trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
1518 in case callerSaves (targetPlatform dflags) r of
1519 True -> trash
1520 False -> nilOL
1521
1522
1523 -- | Get a function pointer to the CLabel specified.
1524 --
1525 -- This is for Haskell functions, function type is assumed, so doesn't work
1526 -- with foreign functions.
1527 getHsFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> UniqSM ExprData
1528 getHsFunc env live lbl
1529 = let dflags = getDflags env
1530 fn = strCLabel_llvm env lbl
1531 ty = funLookup fn env
1532 in case ty of
1533 -- Function in module in right form
1534 Just ty'@(LMFunction sig) -> do
1535 let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False
1536 return (env, fun, nilOL, [])
1537
1538 -- label in module but not function pointer, convert
1539 Just ty' -> do
1540 let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
1541 Nothing Nothing False
1542 (v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $
1543 Cast LM_Bitcast fun (pLift (llvmFunTy dflags live))
1544 return (env, v1, unitOL s1, [])
1545
1546 -- label not in module, create external reference
1547 Nothing -> do
1548 let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible
1549 let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
1550 let top = CmmData Data [([],[ty'])]
1551 let env' = funInsert fn ty' env
1552 return (env', fun, nilOL, [top])
1553
1554
1555 -- | Create a new local var
1556 mkLocalVar :: LlvmType -> UniqSM LlvmVar
1557 mkLocalVar ty = do
1558 un <- getUniqueUs
1559 return $ LMLocalVar un ty
1560
1561
1562 -- | Execute an expression, assigning result to a var
1563 doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement)
1564 doExpr ty expr = do
1565 v <- mkLocalVar ty
1566 return (v, Assignment v expr)
1567
1568
1569 -- | Expand CmmRegOff
1570 expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr
1571 expandCmmReg dflags (reg, off)
1572 = let width = typeWidth (cmmRegType dflags reg)
1573 voff = CmmLit $ CmmInt (fromIntegral off) width
1574 in CmmMachOp (MO_Add width) [CmmReg reg, voff]
1575
1576
1577 -- | Convert a block id into a appropriate Llvm label
1578 blockIdToLlvm :: BlockId -> LlvmVar
1579 blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
1580
1581 -- | Create Llvm int Literal
1582 mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
1583 mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
1584
1585 -- | Convert int type to a LLvmVar of word or i32 size
1586 toI32 :: Integral a => a -> LlvmVar
1587 toI32 = mkIntLit i32
1588
1589 toIWord :: Integral a => DynFlags -> a -> LlvmVar
1590 toIWord dflags = mkIntLit (llvmWord dflags)
1591
1592
1593 -- | Error functions
1594 panic :: String -> a
1595 panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
1596
1597 pprPanic :: String -> SDoc -> a
1598 pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d
1599