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