efa7e9a706e457e6c7b9772c8f5a1f9f99688746
[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
474 (vt, _) -> panic $ "castVars: Can't cast this type ("
475 ++ show vt ++ ") to (" ++ show t ++ ")"
476 in doExpr t $ Cast op v t
477
478
479 -- | Decide what C function to use to implement a CallishMachOp
480 cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString
481 cmmPrimOpFunctions env mop
482 = case mop of
483 MO_F32_Exp -> fsLit "expf"
484 MO_F32_Log -> fsLit "logf"
485 MO_F32_Sqrt -> fsLit "llvm.sqrt.f32"
486 MO_F32_Pwr -> fsLit "llvm.pow.f32"
487
488 MO_F32_Sin -> fsLit "llvm.sin.f32"
489 MO_F32_Cos -> fsLit "llvm.cos.f32"
490 MO_F32_Tan -> fsLit "tanf"
491
492 MO_F32_Asin -> fsLit "asinf"
493 MO_F32_Acos -> fsLit "acosf"
494 MO_F32_Atan -> fsLit "atanf"
495
496 MO_F32_Sinh -> fsLit "sinhf"
497 MO_F32_Cosh -> fsLit "coshf"
498 MO_F32_Tanh -> fsLit "tanhf"
499
500 MO_F64_Exp -> fsLit "exp"
501 MO_F64_Log -> fsLit "log"
502 MO_F64_Sqrt -> fsLit "llvm.sqrt.f64"
503 MO_F64_Pwr -> fsLit "llvm.pow.f64"
504
505 MO_F64_Sin -> fsLit "llvm.sin.f64"
506 MO_F64_Cos -> fsLit "llvm.cos.f64"
507 MO_F64_Tan -> fsLit "tan"
508
509 MO_F64_Asin -> fsLit "asin"
510 MO_F64_Acos -> fsLit "acos"
511 MO_F64_Atan -> fsLit "atan"
512
513 MO_F64_Sinh -> fsLit "sinh"
514 MO_F64_Cosh -> fsLit "cosh"
515 MO_F64_Tanh -> fsLit "tanh"
516
517 MO_Memcpy -> fsLit $ "llvm.memcpy." ++ intrinTy1
518 MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1
519 MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2
520
521 (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w)
522
523 MO_S_QuotRem {} -> unsupported
524 MO_U_QuotRem {} -> unsupported
525 MO_U_QuotRem2 {} -> unsupported
526 MO_Add2 {} -> unsupported
527 MO_U_Mul2 {} -> unsupported
528 MO_WriteBarrier -> unsupported
529 MO_Touch -> unsupported
530 MO_UF_Conv _ -> unsupported
531
532 where
533 dflags = getDflags env
534 intrinTy1 = (if getLlvmVer env >= 28
535 then "p0i8.p0i8." else "") ++ show (llvmWord dflags)
536 intrinTy2 = (if getLlvmVer env >= 28
537 then "p0i8." else "") ++ show (llvmWord dflags)
538 unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
539 ++ " not supported here")
540
541 -- | Tail function calls
542 genJump :: LlvmEnv -> CmmExpr -> [GlobalReg] -> UniqSM StmtData
543
544 -- Call to known function
545 genJump env (CmmLit (CmmLabel lbl)) live = do
546 (env', vf, stmts, top) <- getHsFunc env live lbl
547 (stgRegs, stgStmts) <- funEpilogue env live
548 let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
549 let s2 = Return Nothing
550 return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
551
552
553 -- Call to unknown function / address
554 genJump env expr live = do
555 let fty = llvmFunTy (getDflags env) live
556 (env', vf, stmts, top) <- exprToVar env expr
557
558 let cast = case getVarType vf of
559 ty | isPointer ty -> LM_Bitcast
560 ty | isInt ty -> LM_Inttoptr
561
562 ty -> panic $ "genJump: Expr is of bad type for function call! ("
563 ++ show (ty) ++ ")"
564
565 (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
566 (stgRegs, stgStmts) <- funEpilogue env live
567 let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
568 let s3 = Return Nothing
569 return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
570 top)
571
572
573 -- | CmmAssign operation
574 --
575 -- We use stack allocated variables for CmmReg. The optimiser will replace
576 -- these with registers when possible.
577 genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData
578 genAssign env reg val = do
579 let dflags = getDflags env
580 (env1, vreg, stmts1, top1) = getCmmReg env reg
581 (env2, vval, stmts2, top2) <- exprToVar env1 val
582 let stmts = stmts1 `appOL` stmts2
583
584 let ty = (pLower . getVarType) vreg
585 case isPointer ty && getVarType vval == llvmWord dflags of
586 -- Some registers are pointer types, so need to cast value to pointer
587 True -> do
588 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
589 let s2 = Store v vreg
590 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
591
592 False -> do
593 let s1 = Store vval vreg
594 return (env2, stmts `snocOL` s1, top1 ++ top2)
595
596
597 -- | CmmStore operation
598 genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
599
600 -- First we try to detect a few common cases and produce better code for
601 -- these then the default case. We are mostly trying to detect Cmm code
602 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
603 -- generic case that uses casts and pointer arithmetic
604 genStore env addr@(CmmReg (CmmGlobal r)) val
605 = genStore_fast env addr r 0 val
606
607 genStore env addr@(CmmRegOff (CmmGlobal r) n) val
608 = genStore_fast env addr r n val
609
610 genStore env addr@(CmmMachOp (MO_Add _) [
611 (CmmReg (CmmGlobal r)),
612 (CmmLit (CmmInt n _))])
613 val
614 = genStore_fast env addr r (fromInteger n) val
615
616 genStore env addr@(CmmMachOp (MO_Sub _) [
617 (CmmReg (CmmGlobal r)),
618 (CmmLit (CmmInt n _))])
619 val
620 = genStore_fast env addr r (negate $ fromInteger n) val
621
622 -- generic case
623 genStore env addr val = genStore_slow env addr val [other]
624
625 -- | CmmStore operation
626 -- This is a special case for storing to a global register pointer
627 -- offset such as I32[Sp+8].
628 genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr
629 -> UniqSM StmtData
630 genStore_fast env addr r n val
631 = let dflags = getDflags env
632 gr = lmGlobalRegVar (getDflags env) r
633 meta = [getTBAA r]
634 grt = (pLower . getVarType) gr
635 (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
636 in case isPointer grt && rem == 0 of
637 True -> do
638 (env', vval, stmts, top) <- exprToVar env val
639 (gv, s1) <- doExpr grt $ Load gr
640 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
641 -- We might need a different pointer type, so check
642 case pLower grt == getVarType vval of
643 -- were fine
644 True -> do
645 let s3 = MetaStmt meta $ Store vval ptr
646 return (env', stmts `snocOL` s1 `snocOL` s2
647 `snocOL` s3, top)
648
649 -- cast to pointer type needed
650 False -> do
651 let ty = (pLift . getVarType) vval
652 (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
653 let s4 = MetaStmt meta $ Store vval ptr'
654 return (env', stmts `snocOL` s1 `snocOL` s2
655 `snocOL` s3 `snocOL` s4, top)
656
657 -- If its a bit type then we use the slow method since
658 -- we can't avoid casting anyway.
659 False -> genStore_slow env addr val meta
660
661
662 -- | CmmStore operation
663 -- Generic case. Uses casts and pointer arithmetic if needed.
664 genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData
665 genStore_slow env addr val meta = do
666 (env1, vaddr, stmts1, top1) <- exprToVar env addr
667 (env2, vval, stmts2, top2) <- exprToVar env1 val
668
669 let stmts = stmts1 `appOL` stmts2
670 case getVarType vaddr of
671 -- sometimes we need to cast an int to a pointer before storing
672 LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do
673 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
674 let s2 = MetaStmt meta $ Store v vaddr
675 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
676
677 LMPointer _ -> do
678 let s1 = MetaStmt meta $ Store vval vaddr
679 return (env2, stmts `snocOL` s1, top1 ++ top2)
680
681 i@(LMInt _) | i == llvmWord dflags -> do
682 let vty = pLift $ getVarType vval
683 (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
684 let s2 = MetaStmt meta $ Store vval vptr
685 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
686
687 other ->
688 pprPanic "genStore: ptr not right type!"
689 (PprCmm.pprExpr addr <+> text (
690 "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
691 ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
692 ", Var: " ++ show vaddr))
693 where dflags = getDflags env
694
695
696 -- | Unconditional branch
697 genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData
698 genBranch env id =
699 let label = blockIdToLlvm id
700 in return (env, unitOL $ Branch label, [])
701
702
703 -- | Conditional branch
704 genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData
705 genCondBranch env cond idT idF = do
706 let labelT = blockIdToLlvm idT
707 let labelF = blockIdToLlvm idF
708 -- See Note [Literals and branch conditions].
709 (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
710 if getVarType vc == i1
711 then do
712 let s1 = BranchIf vc labelT labelF
713 return $ (env', stmts `snocOL` s1, top)
714 else
715 panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
716
717 {- Note [Literals and branch conditions]
718 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
719
720 It is important that whenever we generate branch conditions for
721 literals like '1', they are properly narrowed to an LLVM expression of
722 type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
723 a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
724 must be certain to return a properly narrowed type. genLit is
725 responsible for this, in the case of literal integers.
726
727 Often, we won't see direct statements like:
728
729 if(1) {
730 ...
731 } else {
732 ...
733 }
734
735 at this point in the pipeline, because the Glorious Code Generator
736 will do trivial branch elimination in the sinking pass (among others,)
737 which will eliminate the expression entirely.
738
739 However, it's certainly possible and reasonable for this to occur in
740 hand-written C-- code. Consider something like:
741
742 #ifndef SOME_CONDITIONAL
743 #define CHECK_THING(x) 1
744 #else
745 #define CHECK_THING(x) some_operation((x))
746 #endif
747
748 f() {
749
750 if (CHECK_THING(xyz)) {
751 ...
752 } else {
753 ...
754 }
755
756 }
757
758 In such an instance, CHECK_THING might result in an *expression* in
759 one case, and a *literal* in the other, depending on what in
760 particular was #define'd. So we must be sure to properly narrow the
761 literal in this case to i1 as it won't be eliminated beforehand.
762
763 For a real example of this, see ./rts/StgStdThunks.cmm
764
765 -}
766
767
768
769 -- | Switch branch
770 --
771 -- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
772 -- However, they may be defined one day, so we better document this behaviour.
773 genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
774 genSwitch env cond maybe_ids = do
775 (env', vc, stmts, top) <- exprToVar env cond
776 let ty = getVarType vc
777
778 let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ]
779 let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
780 -- out of range is undefied, so lets just branch to first label
781 let (_, defLbl) = head labels
782
783 let s1 = Switch vc defLbl labels
784 return $ (env', stmts `snocOL` s1, top)
785
786
787 -- -----------------------------------------------------------------------------
788 -- * CmmExpr code generation
789 --
790
791 -- | An expression conversion return data:
792 -- * LlvmEnv: The new enviornment
793 -- * LlvmVar: The var holding the result of the expression
794 -- * LlvmStatements: Any statements needed to evaluate the expression
795 -- * LlvmCmmDecl: Any global data needed for this expression
796 type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmDecl])
797
798 -- | Values which can be passed to 'exprToVar' to configure its
799 -- behaviour in certain circumstances.
800 --
801 -- Currently just used for determining if a comparison should return
802 -- a boolean (i1) or a word. See Note [Literals and branch conditions].
803 newtype EOption = EOption { i1Expected :: Bool }
804 -- XXX: EOption is an ugly and inefficient solution to this problem.
805
806 -- | i1 type expected (condition scrutinee).
807 i1Option :: EOption
808 i1Option = EOption True
809
810 -- | Word type expected (usual).
811 wordOption :: EOption
812 wordOption = EOption False
813
814 -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
815 -- expression being stored in the returned LlvmVar.
816 exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
817 exprToVar env = exprToVarOpt env wordOption
818
819 exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
820 exprToVarOpt env opt e = case e of
821
822 CmmLit lit
823 -> genLit opt env lit
824
825 CmmLoad e' ty
826 -> genLoad env e' ty
827
828 -- Cmmreg in expression is the value, so must load. If you want actual
829 -- reg pointer, call getCmmReg directly.
830 CmmReg r -> do
831 let (env', vreg, stmts, top) = getCmmReg env r
832 (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg
833 case (isPointer . getVarType) v1 of
834 True -> do
835 -- Cmm wants the value, so pointer types must be cast to ints
836 (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)
837 return (env', v2, stmts `snocOL` s1 `snocOL` s2, top)
838
839 False -> return (env', v1, stmts `snocOL` s1, top)
840
841 CmmMachOp op exprs
842 -> genMachOp env opt op exprs
843
844 CmmRegOff r i
845 -> exprToVar env $ expandCmmReg dflags (r, i)
846
847 CmmStackSlot _ _
848 -> panic "exprToVar: CmmStackSlot not supported!"
849
850 where dflags = getDflags env
851
852 -- | Handle CmmMachOp expressions
853 genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
854
855 -- Unary Machop
856 genMachOp env _ op [x] = case op of
857
858 MO_Not w ->
859 let all1 = mkIntLit (widthToLlvmInt w) (-1)
860 in negate (widthToLlvmInt w) all1 LM_MO_Xor
861
862 MO_S_Neg w ->
863 let all0 = mkIntLit (widthToLlvmInt w) 0
864 in negate (widthToLlvmInt w) all0 LM_MO_Sub
865
866 MO_F_Neg w ->
867 let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
868 in negate (widthToLlvmFloat w) all0 LM_MO_FSub
869
870 MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
871 MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
872
873 MO_SS_Conv from to
874 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
875
876 MO_UU_Conv from to
877 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
878
879 MO_FF_Conv from to
880 -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
881
882 MO_VS_Neg len w ->
883 let ty = widthToLlvmInt w
884 vecty = LMVector len ty
885 all0 = LMIntLit (-0) ty
886 all0s = LMLitVar $ LMVectorLit (replicate len all0)
887 in negate vecty all0s LM_MO_Sub
888
889 MO_VF_Neg len w ->
890 let ty = widthToLlvmFloat w
891 vecty = LMVector len ty
892 all0 = LMFloatLit (-0) ty
893 all0s = LMLitVar $ LMVectorLit (replicate len all0)
894 in negate vecty all0s LM_MO_FSub
895
896 -- Handle unsupported cases explicitly so we get a warning
897 -- of missing case when new MachOps added
898 MO_Add _ -> panicOp
899 MO_Mul _ -> panicOp
900 MO_Sub _ -> panicOp
901 MO_S_MulMayOflo _ -> panicOp
902 MO_S_Quot _ -> panicOp
903 MO_S_Rem _ -> panicOp
904 MO_U_MulMayOflo _ -> panicOp
905 MO_U_Quot _ -> panicOp
906 MO_U_Rem _ -> panicOp
907
908 MO_Eq _ -> panicOp
909 MO_Ne _ -> panicOp
910 MO_S_Ge _ -> panicOp
911 MO_S_Gt _ -> panicOp
912 MO_S_Le _ -> panicOp
913 MO_S_Lt _ -> panicOp
914 MO_U_Ge _ -> panicOp
915 MO_U_Gt _ -> panicOp
916 MO_U_Le _ -> panicOp
917 MO_U_Lt _ -> panicOp
918
919 MO_F_Add _ -> panicOp
920 MO_F_Sub _ -> panicOp
921 MO_F_Mul _ -> panicOp
922 MO_F_Quot _ -> panicOp
923 MO_F_Eq _ -> panicOp
924 MO_F_Ne _ -> panicOp
925 MO_F_Ge _ -> panicOp
926 MO_F_Gt _ -> panicOp
927 MO_F_Le _ -> panicOp
928 MO_F_Lt _ -> panicOp
929
930 MO_And _ -> panicOp
931 MO_Or _ -> panicOp
932 MO_Xor _ -> panicOp
933 MO_Shl _ -> panicOp
934 MO_U_Shr _ -> panicOp
935 MO_S_Shr _ -> panicOp
936
937 MO_V_Insert _ _ -> panicOp
938 MO_V_Extract _ _ -> panicOp
939
940 MO_V_Add _ _ -> panicOp
941 MO_V_Sub _ _ -> panicOp
942 MO_V_Mul _ _ -> panicOp
943
944 MO_VS_Quot _ _ -> panicOp
945 MO_VS_Rem _ _ -> panicOp
946
947 MO_VF_Add _ _ -> panicOp
948 MO_VF_Sub _ _ -> panicOp
949 MO_VF_Mul _ _ -> panicOp
950 MO_VF_Quot _ _ -> panicOp
951
952 where
953 dflags = getDflags env
954
955 negate ty v2 negOp = do
956 (env', vx, stmts, top) <- exprToVar env x
957 (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
958 return (env', v1, stmts `snocOL` s1, top)
959
960 fiConv ty convOp = do
961 (env', vx, stmts, top) <- exprToVar env x
962 (v1, s1) <- doExpr ty $ Cast convOp vx ty
963 return (env', v1, stmts `snocOL` s1, top)
964
965 sameConv from ty reduce expand = do
966 x'@(env', vx, stmts, top) <- exprToVar env x
967 let sameConv' op = do
968 (v1, s1) <- doExpr ty $ Cast op vx ty
969 return (env', v1, stmts `snocOL` s1, top)
970 let toWidth = llvmWidthInBits dflags ty
971 -- LLVM doesn't like trying to convert to same width, so
972 -- need to check for that as we do get Cmm code doing it.
973 case widthInBits from of
974 w | w < toWidth -> sameConv' expand
975 w | w > toWidth -> sameConv' reduce
976 _w -> return x'
977
978 panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encourntered"
979 ++ "with one argument! (" ++ show op ++ ")"
980
981 -- Handle GlobalRegs pointers
982 genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
983 = genMachOp_fast env opt o r (fromInteger n) e
984
985 genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
986 = genMachOp_fast env opt o r (negate . fromInteger $ n) e
987
988 -- Generic case
989 genMachOp env opt op e = genMachOp_slow env opt op e
990
991
992 -- | Handle CmmMachOp expressions
993 -- This is a specialised method that handles Global register manipulations like
994 -- 'Sp - 16', using the getelementptr instruction.
995 genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
996 -> UniqSM ExprData
997 genMachOp_fast env opt op r n e
998 = let dflags = getDflags env
999 gr = lmGlobalRegVar dflags r
1000 grt = (pLower . getVarType) gr
1001 (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
1002 in case isPointer grt && rem == 0 of
1003 True -> do
1004 (gv, s1) <- doExpr grt $ Load gr
1005 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
1006 (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)
1007 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])
1008
1009 False -> genMachOp_slow env opt op e
1010
1011
1012 -- | Handle CmmMachOp expressions
1013 -- This handles all the cases not handle by the specialised genMachOp_fast.
1014 genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
1015
1016 -- Element extraction
1017 genMachOp_slow env _ (MO_V_Extract {}) [val, idx] = do
1018 (env1, vval, stmts1, top1) <- exprToVar env val
1019 (env2, vidx, stmts2, top2) <- exprToVar env1 idx
1020 let (LMVector _ ty) = getVarType vval
1021 (v1, s1) <- doExpr ty $ Extract vval vidx
1022 return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
1023
1024 -- Element insertion
1025 genMachOp_slow env _ (MO_V_Insert {}) [val, elt, idx] = do
1026 (env1, vval, stmts1, top1) <- exprToVar env val
1027 (env2, velt, stmts2, top2) <- exprToVar env1 elt
1028 (env3, vidx, stmts3, top3) <- exprToVar env2 idx
1029 let ty = getVarType vval
1030 (v1, s1) <- doExpr ty $ Insert vval velt vidx
1031 return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1,
1032 top1 ++ top2 ++ top3)
1033
1034 -- Binary MachOp
1035 genMachOp_slow env opt op [x, y] = case op of
1036
1037 MO_Eq _ -> genBinComp opt LM_CMP_Eq
1038 MO_Ne _ -> genBinComp opt LM_CMP_Ne
1039
1040 MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
1041 MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
1042 MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
1043 MO_S_Le _ -> genBinComp opt LM_CMP_Sle
1044
1045 MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
1046 MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
1047 MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
1048 MO_U_Le _ -> genBinComp opt LM_CMP_Ule
1049
1050 MO_Add _ -> genBinMach LM_MO_Add
1051 MO_Sub _ -> genBinMach LM_MO_Sub
1052 MO_Mul _ -> genBinMach LM_MO_Mul
1053
1054 MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
1055
1056 MO_S_MulMayOflo w -> isSMulOK w x y
1057
1058 MO_S_Quot _ -> genBinMach LM_MO_SDiv
1059 MO_S_Rem _ -> genBinMach LM_MO_SRem
1060
1061 MO_U_Quot _ -> genBinMach LM_MO_UDiv
1062 MO_U_Rem _ -> genBinMach LM_MO_URem
1063
1064 MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
1065 MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
1066 MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
1067 MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
1068 MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
1069 MO_F_Le _ -> genBinComp opt LM_CMP_Fle
1070
1071 MO_F_Add _ -> genBinMach LM_MO_FAdd
1072 MO_F_Sub _ -> genBinMach LM_MO_FSub
1073 MO_F_Mul _ -> genBinMach LM_MO_FMul
1074 MO_F_Quot _ -> genBinMach LM_MO_FDiv
1075
1076 MO_And _ -> genBinMach LM_MO_And
1077 MO_Or _ -> genBinMach LM_MO_Or
1078 MO_Xor _ -> genBinMach LM_MO_Xor
1079 MO_Shl _ -> genBinMach LM_MO_Shl
1080 MO_U_Shr _ -> genBinMach LM_MO_LShr
1081 MO_S_Shr _ -> genBinMach LM_MO_AShr
1082
1083 MO_V_Add _ _ -> genBinMach LM_MO_Add
1084 MO_V_Sub _ _ -> genBinMach LM_MO_Sub
1085 MO_V_Mul _ _ -> genBinMach LM_MO_Mul
1086
1087 MO_VS_Quot _ _ -> genBinMach LM_MO_SDiv
1088 MO_VS_Rem _ _ -> genBinMach LM_MO_SRem
1089
1090 MO_VF_Add _ _ -> genBinMach LM_MO_FAdd
1091 MO_VF_Sub _ _ -> genBinMach LM_MO_FSub
1092 MO_VF_Mul _ _ -> genBinMach LM_MO_FMul
1093 MO_VF_Quot _ _ -> genBinMach LM_MO_FDiv
1094
1095 MO_Not _ -> panicOp
1096 MO_S_Neg _ -> panicOp
1097 MO_F_Neg _ -> panicOp
1098
1099 MO_SF_Conv _ _ -> panicOp
1100 MO_FS_Conv _ _ -> panicOp
1101 MO_SS_Conv _ _ -> panicOp
1102 MO_UU_Conv _ _ -> panicOp
1103 MO_FF_Conv _ _ -> panicOp
1104
1105 MO_V_Insert {} -> panicOp
1106 MO_V_Extract {} -> panicOp
1107
1108 MO_VS_Neg {} -> panicOp
1109
1110 MO_VF_Neg {} -> panicOp
1111
1112 where
1113 dflags = getDflags env
1114
1115 binLlvmOp ty binOp = do
1116 (env1, vx, stmts1, top1) <- exprToVar env x
1117 (env2, vy, stmts2, top2) <- exprToVar env1 y
1118 if getVarType vx == getVarType vy
1119 then do
1120 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
1121 return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1,
1122 top1 ++ top2)
1123
1124 else do
1125 -- Error. Continue anyway so we can debug the generated ll file.
1126 let dflags = getDflags env
1127 style = mkCodeStyle CStyle
1128 toString doc = renderWithStyle dflags doc style
1129 cmmToStr = (lines . toString . PprCmm.pprExpr)
1130 let dx = Comment $ map fsLit $ cmmToStr x
1131 let dy = Comment $ map fsLit $ cmmToStr y
1132 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
1133 let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
1134 `snocOL` dy `snocOL` s1
1135 return (env2, v1, allStmts, top1 ++ top2)
1136
1137 -- | Need to use EOption here as Cmm expects word size results from
1138 -- comparisons while LLVM return i1. Need to extend to llvmWord type
1139 -- if expected. See Note [Literals and branch conditions].
1140 genBinComp opt cmp = do
1141 ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
1142 if getVarType v1 == i1
1143 then case i1Expected opt of
1144 True -> return ed
1145 False -> do
1146 let w_ = llvmWord dflags
1147 (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
1148 return (env', v2, stmts `snocOL` s1, top)
1149 else
1150 panic $ "genBinComp: Compare returned type other then i1! "
1151 ++ (show $ getVarType v1)
1152
1153 genBinMach op = binLlvmOp getVarType (LlvmOp op)
1154
1155 -- | Detect if overflow will occur in signed multiply of the two
1156 -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
1157 -- implementation. Its much longer due to type information/safety.
1158 -- This should actually compile to only about 3 asm instructions.
1159 isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData
1160 isSMulOK _ x y = do
1161 (env1, vx, stmts1, top1) <- exprToVar env x
1162 (env2, vy, stmts2, top2) <- exprToVar env1 y
1163
1164 let word = getVarType vx
1165 let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
1166 let shift = llvmWidthInBits dflags word
1167 let shift1 = toIWord dflags (shift - 1)
1168 let shift2 = toIWord dflags shift
1169
1170 if isInt word
1171 then do
1172 (x1, s1) <- doExpr word2 $ Cast LM_Sext vx word2
1173 (y1, s2) <- doExpr word2 $ Cast LM_Sext vy word2
1174 (r1, s3) <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
1175 (rlow1, s4) <- doExpr word $ Cast LM_Trunc r1 word
1176 (rlow2, s5) <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
1177 (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
1178 (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
1179 (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
1180 let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
1181 `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
1182 return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts,
1183 top1 ++ top2)
1184
1185 else
1186 panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"
1187
1188 panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encourntered"
1189 ++ "with two arguments! (" ++ show op ++ ")"
1190
1191 -- More then two expression, invalid!
1192 genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
1193
1194
1195 -- | Handle CmmLoad expression.
1196 genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
1197
1198 -- First we try to detect a few common cases and produce better code for
1199 -- these then the default case. We are mostly trying to detect Cmm code
1200 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
1201 -- generic case that uses casts and pointer arithmetic
1202 genLoad env e@(CmmReg (CmmGlobal r)) ty
1203 = genLoad_fast env e r 0 ty
1204
1205 genLoad env e@(CmmRegOff (CmmGlobal r) n) ty
1206 = genLoad_fast env e r n ty
1207
1208 genLoad env e@(CmmMachOp (MO_Add _) [
1209 (CmmReg (CmmGlobal r)),
1210 (CmmLit (CmmInt n _))])
1211 ty
1212 = genLoad_fast env e r (fromInteger n) ty
1213
1214 genLoad env e@(CmmMachOp (MO_Sub _) [
1215 (CmmReg (CmmGlobal r)),
1216 (CmmLit (CmmInt n _))])
1217 ty
1218 = genLoad_fast env e r (negate $ fromInteger n) ty
1219
1220 -- generic case
1221 genLoad env e ty = genLoad_slow env e ty [other]
1222
1223 -- | Handle CmmLoad expression.
1224 -- This is a special case for loading from a global register pointer
1225 -- offset such as I32[Sp+8].
1226 genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
1227 -> UniqSM ExprData
1228 genLoad_fast env e r n ty =
1229 let dflags = getDflags env
1230 gr = lmGlobalRegVar dflags r
1231 meta = [getTBAA r]
1232 grt = (pLower . getVarType) gr
1233 ty' = cmmToLlvmType ty
1234 (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
1235 in case isPointer grt && rem == 0 of
1236 True -> do
1237 (gv, s1) <- doExpr grt $ Load gr
1238 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
1239 -- We might need a different pointer type, so check
1240 case grt == ty' of
1241 -- were fine
1242 True -> do
1243 (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr)
1244 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3,
1245 [])
1246
1247 -- cast to pointer type needed
1248 False -> do
1249 let pty = pLift ty'
1250 (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
1251 (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr')
1252 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3
1253 `snocOL` s4, [])
1254
1255 -- If its a bit type then we use the slow method since
1256 -- we can't avoid casting anyway.
1257 False -> genLoad_slow env e ty meta
1258
1259
1260 -- | Handle Cmm load expression.
1261 -- Generic case. Uses casts and pointer arithmetic if needed.
1262 genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData
1263 genLoad_slow env e ty meta = do
1264 (env', iptr, stmts, tops) <- exprToVar env e
1265 case getVarType iptr of
1266 LMPointer _ -> do
1267 (dvar, load) <- doExpr (cmmToLlvmType ty)
1268 (MetaExpr meta $ Load iptr)
1269 return (env', dvar, stmts `snocOL` load, tops)
1270
1271 i@(LMInt _) | i == llvmWord dflags -> do
1272 let pty = LMPointer $ cmmToLlvmType ty
1273 (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty
1274 (dvar, load) <- doExpr (cmmToLlvmType ty)
1275 (MetaExpr meta $ Load ptr)
1276 return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
1277
1278 other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
1279 (PprCmm.pprExpr e <+> text (
1280 "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
1281 ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
1282 ", Var: " ++ show iptr))
1283 where dflags = getDflags env
1284
1285 -- | Handle CmmReg expression
1286 --
1287 -- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an
1288 -- equivalent SSA form and avoids having to deal with Phi node insertion.
1289 -- This is also the approach recommended by LLVM developers.
1290 getCmmReg :: LlvmEnv -> CmmReg -> ExprData
1291 getCmmReg env r@(CmmLocal (LocalReg un _))
1292 = let exists = varLookup un env
1293 (newv, stmts) = allocReg r
1294 nenv = varInsert un (pLower $ getVarType newv) env
1295 in case exists of
1296 Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, [])
1297 Nothing -> (nenv, newv, stmts, [])
1298
1299 getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar (getDflags env) g, nilOL, [])
1300
1301
1302 -- | Allocate a CmmReg on the stack
1303 allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
1304 allocReg (CmmLocal (LocalReg un ty))
1305 = let ty' = cmmToLlvmType ty
1306 var = LMLocalVar un (LMPointer ty')
1307 alc = Alloca ty' 1
1308 in (var, unitOL $ Assignment var alc)
1309
1310 allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
1311 ++ " have been handled elsewhere!"
1312
1313
1314 -- | Generate code for a literal
1315 genLit :: EOption -> LlvmEnv -> CmmLit -> UniqSM ExprData
1316 genLit opt env (CmmInt i w)
1317 -- See Note [Literals and branch conditions].
1318 = let width | i1Expected opt = i1
1319 | otherwise = LMInt (widthInBits w)
1320 -- comm = Comment [ fsLit $ "EOption: " ++ show opt
1321 -- , fsLit $ "Width : " ++ show w
1322 -- , fsLit $ "Width' : " ++ show (widthInBits w)
1323 -- ]
1324 in return (env, mkIntLit width i, nilOL, [])
1325
1326 genLit _ env (CmmFloat r w)
1327 = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
1328 nilOL, [])
1329
1330 genLit opt env (CmmVec ls)
1331 = do llvmLits <- mapM toLlvmLit ls
1332 return (env, LMLitVar $ LMVectorLit llvmLits, nilOL, [])
1333 where
1334 toLlvmLit :: CmmLit -> UniqSM LlvmLit
1335 toLlvmLit lit = do
1336 (_, llvmLitVar, _, _) <- genLit opt env lit
1337 case llvmLitVar of
1338 LMLitVar llvmLit -> return llvmLit
1339 _ -> panic "genLit"
1340
1341 genLit _ env cmm@(CmmLabel l)
1342 = let dflags = getDflags env
1343 label = strCLabel_llvm env l
1344 ty = funLookup label env
1345 lmty = cmmToLlvmType $ cmmLitType dflags cmm
1346 in case ty of
1347 -- Make generic external label definition and then pointer to it
1348 Nothing -> do
1349 let glob@(var, _) = genStringLabelRef dflags label
1350 let ldata = [CmmData Data [([glob], [])]]
1351 let env' = funInsert label (pLower $ getVarType var) env
1352 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
1353 return (env', v1, unitOL s1, ldata)
1354
1355 -- Referenced data exists in this module, retrieve type and make
1356 -- pointer to it.
1357 Just ty' -> do
1358 let var = LMGlobalVar label (LMPointer ty')
1359 ExternallyVisible Nothing Nothing False
1360 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
1361 return (env, v1, unitOL s1, [])
1362
1363 genLit opt env (CmmLabelOff label off) = do
1364 let dflags = getDflags env
1365 (env', vlbl, stmts, stat) <- genLit opt env (CmmLabel label)
1366 let voff = toIWord dflags off
1367 (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
1368 return (env', v1, stmts `snocOL` s1, stat)
1369
1370 genLit opt env (CmmLabelDiffOff l1 l2 off) = do
1371 let dflags = getDflags env
1372 (env1, vl1, stmts1, stat1) <- genLit opt env (CmmLabel l1)
1373 (env2, vl2, stmts2, stat2) <- genLit opt env1 (CmmLabel l2)
1374 let voff = toIWord dflags off
1375 let ty1 = getVarType vl1
1376 let ty2 = getVarType vl2
1377 if (isInt ty1) && (isInt ty2)
1378 && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)
1379
1380 then do
1381 (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
1382 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
1383 return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
1384 stat1 ++ stat2)
1385
1386 else
1387 panic "genLit: CmmLabelDiffOff encountered with different label ty!"
1388
1389 genLit opt env (CmmBlock b)
1390 = genLit opt env (CmmLabel $ infoTblLbl b)
1391
1392 genLit _ _ CmmHighStackMark
1393 = panic "genStaticLit - CmmHighStackMark unsupported!"
1394
1395
1396 -- -----------------------------------------------------------------------------
1397 -- * Misc
1398 --
1399
1400 -- | Function prologue. Load STG arguments into variables for function.
1401 funPrologue :: DynFlags -> LiveGlobalRegs -> [LlvmStatement]
1402 funPrologue dflags live = concat $ map getReg $ activeStgRegs platform
1403 where platform = targetPlatform dflags
1404 isLive r = r `elem` alwaysLive || r `elem` live
1405 getReg rr =
1406 let reg = lmGlobalRegVar dflags rr
1407 arg = lmGlobalRegArg dflags rr
1408 ty = (pLower . getVarType) reg
1409 trash = LMLitVar $ LMUndefLit ty
1410 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
1411 in
1412 if isLive rr
1413 then [alloc, Store arg reg]
1414 else [alloc, Store trash reg]
1415
1416
1417 -- | Function epilogue. Load STG variables to use as argument for call.
1418 -- STG Liveness optimisation done here.
1419 funEpilogue :: LlvmEnv -> LiveGlobalRegs -> UniqSM ([LlvmVar], LlvmStatements)
1420
1421 -- Have information and liveness optimisation is enabled
1422 funEpilogue env live = do
1423 loads <- mapM loadExpr (filter isPassed (activeStgRegs platform))
1424 let (vars, stmts) = unzip loads
1425 return (vars, concatOL stmts)
1426 where
1427 dflags = getDflags env
1428 platform = targetPlatform dflags
1429 isLive r = r `elem` alwaysLive || r `elem` live
1430 isPassed r = not (isFloat r) || isLive r
1431 isFloat (FloatReg _) = True
1432 isFloat (DoubleReg _) = True
1433 isFloat _ = False
1434 loadExpr r | isLive r = do
1435 let reg = lmGlobalRegVar dflags r
1436 (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
1437 return (v, unitOL s)
1438 loadExpr r = do
1439 let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
1440 return (LMLitVar $ LMUndefLit ty, unitOL Nop)
1441
1442
1443 -- | A serries of statements to trash all the STG registers.
1444 --
1445 -- In LLVM we pass the STG registers around everywhere in function calls.
1446 -- So this means LLVM considers them live across the entire function, when
1447 -- in reality they usually aren't. For Caller save registers across C calls
1448 -- the saving and restoring of them is done by the Cmm code generator,
1449 -- using Cmm local vars. So to stop LLVM saving them as well (and saving
1450 -- all of them since it thinks they're always live, we trash them just
1451 -- before the call by assigning the 'undef' value to them. The ones we
1452 -- need are restored from the Cmm local var and the ones we don't need
1453 -- are fine to be trashed.
1454 trashStmts :: DynFlags -> LlvmStatements
1455 trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform
1456 where platform = targetPlatform dflags
1457 trashReg r =
1458 let reg = lmGlobalRegVar dflags r
1459 ty = (pLower . getVarType) reg
1460 trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
1461 in case callerSaves (targetPlatform dflags) r of
1462 True -> trash
1463 False -> nilOL
1464
1465
1466 -- | Get a function pointer to the CLabel specified.
1467 --
1468 -- This is for Haskell functions, function type is assumed, so doesn't work
1469 -- with foreign functions.
1470 getHsFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> UniqSM ExprData
1471 getHsFunc env live lbl
1472 = let dflags = getDflags env
1473 fn = strCLabel_llvm env lbl
1474 ty = funLookup fn env
1475 in case ty of
1476 -- Function in module in right form
1477 Just ty'@(LMFunction sig) -> do
1478 let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False
1479 return (env, fun, nilOL, [])
1480
1481 -- label in module but not function pointer, convert
1482 Just ty' -> do
1483 let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
1484 Nothing Nothing False
1485 (v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $
1486 Cast LM_Bitcast fun (pLift (llvmFunTy dflags live))
1487 return (env, v1, unitOL s1, [])
1488
1489 -- label not in module, create external reference
1490 Nothing -> do
1491 let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible
1492 let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
1493 let top = CmmData Data [([],[ty'])]
1494 let env' = funInsert fn ty' env
1495 return (env', fun, nilOL, [top])
1496
1497
1498 -- | Create a new local var
1499 mkLocalVar :: LlvmType -> UniqSM LlvmVar
1500 mkLocalVar ty = do
1501 un <- getUniqueUs
1502 return $ LMLocalVar un ty
1503
1504
1505 -- | Execute an expression, assigning result to a var
1506 doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement)
1507 doExpr ty expr = do
1508 v <- mkLocalVar ty
1509 return (v, Assignment v expr)
1510
1511
1512 -- | Expand CmmRegOff
1513 expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr
1514 expandCmmReg dflags (reg, off)
1515 = let width = typeWidth (cmmRegType dflags reg)
1516 voff = CmmLit $ CmmInt (fromIntegral off) width
1517 in CmmMachOp (MO_Add width) [CmmReg reg, voff]
1518
1519
1520 -- | Convert a block id into a appropriate Llvm label
1521 blockIdToLlvm :: BlockId -> LlvmVar
1522 blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
1523
1524 -- | Create Llvm int Literal
1525 mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
1526 mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
1527
1528 -- | Convert int type to a LLvmVar of word or i32 size
1529 toI32 :: Integral a => a -> LlvmVar
1530 toI32 = mkIntLit i32
1531
1532 toIWord :: Integral a => DynFlags -> a -> LlvmVar
1533 toIWord dflags = mkIntLit (llvmWord dflags)
1534
1535
1536 -- | Error functions
1537 panic :: String -> a
1538 panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
1539
1540 pprPanic :: String -> SDoc -> a
1541 pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d
1542