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