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