1 {-# OPTIONS -fno-warn-type-defaults #-}
2 -- ----------------------------------------------------------------------------
3 -- | Handle conversion of CmmProc to LLVM code.
6 module LlvmCodeGen.CodeGen ( genLlvmProc ) where
8 #include "HsVersions.h"
11 import LlvmCodeGen.Base
12 import LlvmCodeGen.Regs
15 import CgUtils ( activeStgRegs, callerSaves )
18 import qualified OldPprCmm as PprCmm
23 import Outputable hiding ( panic, pprPanic )
24 import qualified Outputable
29 import Data.List ( partition )
30 import Control.Monad ( liftM )
32 type LlvmStatements = OrdList LlvmStatement
35 -- -----------------------------------------------------------------------------
36 -- | Top-level of the LLVM proc Code generator
38 genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop])
39 genLlvmProc env (CmmData _ _)
42 genLlvmProc env (CmmProc _ _ (ListGraph []))
45 genLlvmProc env (CmmProc info lbl (ListGraph blocks))
47 (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
49 let proc = CmmProc info lbl (ListGraph lmblocks)
50 let tops = lmdata ++ [proc]
55 -- -----------------------------------------------------------------------------
56 -- * Block code generation
59 -- | Generate code for a list of blocks that make up a complete procedure.
60 basicBlocksCodeGen :: LlvmEnv
62 -> ( [LlvmBasicBlock] , [LlvmCmmTop] )
63 -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmTop] )
64 basicBlocksCodeGen env ([]) (blocks, tops)
65 = do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
66 let allocs' = concat allocs
67 let ((BasicBlock id fstmts):rblks) = blocks'
69 let fblocks = (BasicBlock id (fplog ++ allocs' ++ fstmts)):rblks
70 return (env, fblocks, tops)
72 basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
73 = do (env', lb, lt) <- basicBlockCodeGen env block
74 let lblocks = lblocks' ++ lb
75 let ltops = ltops' ++ lt
76 basicBlocksCodeGen env' blocks (lblocks, ltops)
79 -- | Allocations need to be extracted so they can be moved to the entry
80 -- of a function to make sure they dominate all possible paths in the CFG.
81 dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
82 dominateAllocs (BasicBlock id stmts)
83 = let (allocs, stmts') = partition isAlloc stmts
84 isAlloc (Assignment _ (Alloca _ _)) = True
85 isAlloc _other = False
86 in (BasicBlock id stmts', allocs)
89 -- | Generate code for one block
90 basicBlockCodeGen :: LlvmEnv
92 -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmTop] )
93 basicBlockCodeGen env (BasicBlock id stmts)
94 = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
95 return (env', [BasicBlock id (fromOL instrs)], top)
98 -- -----------------------------------------------------------------------------
99 -- * CmmStmt code generation
102 -- A statement conversion return data.
103 -- * LlvmEnv: The new environment
104 -- * LlvmStatements: The compiled LLVM statements.
105 -- * LlvmCmmTop: Any global data needed.
106 type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmTop])
109 -- | Convert a list of CmmStmt's to LlvmStatement's
110 stmtsToInstrs :: LlvmEnv -> [CmmStmt] -> (LlvmStatements, [LlvmCmmTop])
112 stmtsToInstrs env [] (llvm, top)
113 = return (env, llvm, top)
115 stmtsToInstrs env (stmt : stmts) (llvm, top)
116 = do (env', instrs, tops) <- stmtToInstrs env stmt
117 stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops)
120 -- | Convert a CmmStmt to a list of LlvmStatement's
121 stmtToInstrs :: LlvmEnv -> CmmStmt
123 stmtToInstrs env stmt = case stmt of
125 CmmNop -> return (env, nilOL, [])
126 CmmComment _ -> return (env, nilOL, []) -- nuke comments
128 CmmAssign reg src -> genAssign env reg src
129 CmmStore addr src -> genStore env addr src
131 CmmBranch id -> genBranch env id
132 CmmCondBranch arg id -> genCondBranch env arg id
133 CmmSwitch arg ids -> genSwitch env arg ids
136 CmmCall target res args _ ret
137 -> genCall env target res args ret
140 CmmJump arg _ -> genJump env arg
142 -- CPS, only tail calls, no return's
143 -- Actually, there are a few return statements that occur because of hand
146 -> return (env, unitOL $ Return Nothing, [])
150 genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual]
151 -> CmmReturnInfo -> UniqSM StmtData
153 -- Write barrier needs to be handled specially as it is implemented as an LLVM
154 -- intrinsic function.
155 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
156 genCall env (CmmPrim MO_WriteBarrier) _ _ _ = return (env, nilOL, [])
159 genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
160 let fname = fsLit "llvm.memory.barrier"
161 let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
162 FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign
163 let fty = LMFunction funSig
165 let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False
166 let tops = case funLookup fname env of
168 Nothing -> [CmmData Data [([],[fty])]]
170 let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue]
171 let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs
172 let env' = funInsert fname fty env
174 return (env', unitOL s1, tops)
178 lmTrue = mkIntLit i1 (-1)
181 -- Handle memcpy function specifically since llvm's intrinsic version takes
182 -- some extra parameters.
183 genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy ||
185 op == MO_Memmove = do
186 let (isVolTy, isVolVal) = if getLlvmVer env >= 28
187 then ([i1], [mkIntLit i1 0]) else ([], [])
188 argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy
189 | otherwise = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy
190 funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
191 CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
193 (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
194 (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t
195 (argVars', stmts3) <- castVars $ zip argVars argTy
197 let arguments = argVars' ++ isVolVal
198 call = Expr $ Call StdCall fptr arguments []
199 stmts = stmts1 `appOL` stmts2 `appOL` stmts3
200 `appOL` trashStmts `snocOL` call
201 return (env2, stmts, top1 ++ top2)
203 -- Handle all other foreign calls and prim ops.
204 genCall env target res args ret = do
207 let arg_type (CmmHinted _ AddrHint) = i8Ptr
208 -- cast pointers to i8*. Llvm equivalent of void*
209 arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType expr
212 let ret_type ([]) = LMVoid
213 ret_type ([CmmHinted _ AddrHint]) = i8Ptr
214 ret_type ([CmmHinted reg _]) = cmmToLlvmType $ localRegType reg
215 ret_type t = panic $ "genCall: Too many return values! Can only handle"
216 ++ " 0 or 1, given " ++ show (length t) ++ "."
218 -- extract Cmm call convention
219 let cconv = case target of
220 CmmCallee _ conv -> conv
221 CmmPrim _ -> PrimCallConv
223 -- translate to LLVM call convention
224 let lmconv = case cconv of
225 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
226 StdCallConv -> CC_X86_Stdcc
228 StdCallConv -> CC_Ccc
231 PrimCallConv -> CC_Ccc
232 CmmCallConv -> panic "CmmCallConv not supported here!"
235 Some of the possibilities here are a worry with the use of a custom
236 calling convention for passing STG args. In practice the more
237 dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
239 The native code generator only handles StdCall and CCallConv.
243 let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs
244 | otherwise = llvmStdFunAttrs
247 let ccTy = StdCall -- tail calls should be done through CmmJump
248 let retTy = ret_type res
249 let argTy = tysToParams $ map arg_type args
250 let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
251 lmconv retTy FixedArgs argTy llvmFunAlign
254 (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
255 (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target
257 let retStmt | ccTy == TailCall = unitOL $ Return Nothing
258 | ret == CmmNeverReturns = unitOL $ Unreachable
261 let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts
263 -- make the actual call
266 let s1 = Expr $ Call ccTy fptr argVars fnAttrs
267 let allStmts = stmts `snocOL` s1 `appOL` retStmt
268 return (env2, allStmts, top1 ++ top2)
271 (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
272 -- get the return register
273 let ret_reg ([CmmHinted reg hint]) = (reg, hint)
274 ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
275 ++ " 1, given " ++ show (length t) ++ "."
276 let (creg, _) = ret_reg res
277 let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
278 let allStmts = stmts `snocOL` s1 `appOL` stmts3
279 if retTy == pLower (getVarType vreg)
281 let s2 = Store v1 vreg
282 return (env3, allStmts `snocOL` s2 `appOL` retStmt,
283 top1 ++ top2 ++ top3)
285 let ty = pLower $ getVarType vreg
287 vt | isPointer vt -> LM_Bitcast
288 | isInt vt -> LM_Ptrtoint
290 panic $ "genCall: CmmReg bad match for"
293 (v2, s2) <- doExpr ty $ Cast op v1 ty
294 let s3 = Store v2 vreg
295 return (env3, allStmts `snocOL` s2 `snocOL` s3
296 `appOL` retStmt, top1 ++ top2 ++ top3)
299 -- | Create a function pointer from a target.
300 getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget
302 getFunPtr env funTy targ = case targ of
303 CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm lbl
305 CmmCallee expr _ -> do
306 (env', v1, stmts, top) <- exprToVar env expr
307 let fty = funTy $ fsLit "dynamic"
308 cast = case getVarType v1 of
309 ty | isPointer ty -> LM_Bitcast
310 ty | isInt ty -> LM_Inttoptr
312 ty -> panic $ "genCall: Expr is of bad type for function"
313 ++ " call! (" ++ show (ty) ++ ")"
315 (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
316 return (env', v2, stmts `snocOL` s1, top)
318 CmmPrim mop -> litCase $ cmmPrimOpFunctions env mop
322 case funLookup name env of
323 Just ty'@(LMFunction sig) -> do
324 -- Function in module in right form
325 let fun = LMGlobalVar name ty' (funcLinkage sig)
326 Nothing Nothing False
327 return (env, fun, nilOL, [])
330 -- label in module but not function pointer, convert
331 let fty@(LMFunction sig) = funTy name
332 fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
333 Nothing Nothing False
334 (v1, s1) <- doExpr (pLift fty)
335 $ Cast LM_Bitcast fun (pLift fty)
336 return (env, v1, unitOL s1, [])
339 -- label not in module, create external reference
340 let fty@(LMFunction sig) = funTy name
341 fun = LMGlobalVar name fty (funcLinkage sig)
342 Nothing Nothing False
343 top = [CmmData Data [([],[fty])]]
344 env' = funInsert name fty env
345 return (env', fun, nilOL, top)
348 -- | Conversion of call arguments.
351 -> ([LlvmVar], LlvmStatements, [LlvmCmmTop])
352 -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmTop])
354 arg_vars env [] (vars, stmts, tops)
355 = return (env, vars, stmts, tops)
357 arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
358 = do (env', v1, stmts', top') <- exprToVar env e
359 let op = case getVarType v1 of
360 ty | isPointer ty -> LM_Bitcast
361 ty | isInt ty -> LM_Inttoptr
363 a -> panic $ "genCall: Can't cast llvmType to i8*! ("
366 (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
367 arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
370 arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
371 = do (env', v1, stmts', top') <- exprToVar env e
372 arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
375 -- | Cast a collection of LLVM variables to specific types.
376 castVars :: [(LlvmVar, LlvmType)]
377 -> UniqSM ([LlvmVar], LlvmStatements)
379 done <- mapM (uncurry castVar) vars
380 let (vars', stmts) = unzip done
381 return (vars', toOL stmts)
383 -- | Cast an LLVM variable to a specific type, panicing if it can't be done.
384 castVar :: LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement)
385 castVar v t | getVarType v == t
389 = let op = case (getVarType v, t) of
391 -> if n < m then LM_Sext else LM_Trunc
392 (vt, _) | isFloat vt && isFloat t
393 -> if llvmWidthInBits vt < llvmWidthInBits t
394 then LM_Fpext else LM_Fptrunc
395 (vt, _) | isInt vt && isFloat t -> LM_Sitofp
396 (vt, _) | isFloat vt && isInt t -> LM_Fptosi
397 (vt, _) | isInt vt && isPointer t -> LM_Inttoptr
398 (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint
399 (vt, _) | isPointer vt && isPointer t -> LM_Bitcast
401 (vt, _) -> panic $ "castVars: Can't cast this type ("
402 ++ show vt ++ ") to (" ++ show t ++ ")"
403 in doExpr t $ Cast op v t
406 -- | Decide what C function to use to implement a CallishMachOp
407 cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString
408 cmmPrimOpFunctions env mop
410 MO_F32_Exp -> fsLit "expf"
411 MO_F32_Log -> fsLit "logf"
412 MO_F32_Sqrt -> fsLit "llvm.sqrt.f32"
413 MO_F32_Pwr -> fsLit "llvm.pow.f32"
415 MO_F32_Sin -> fsLit "llvm.sin.f32"
416 MO_F32_Cos -> fsLit "llvm.cos.f32"
417 MO_F32_Tan -> fsLit "tanf"
419 MO_F32_Asin -> fsLit "asinf"
420 MO_F32_Acos -> fsLit "acosf"
421 MO_F32_Atan -> fsLit "atanf"
423 MO_F32_Sinh -> fsLit "sinhf"
424 MO_F32_Cosh -> fsLit "coshf"
425 MO_F32_Tanh -> fsLit "tanhf"
427 MO_F64_Exp -> fsLit "exp"
428 MO_F64_Log -> fsLit "log"
429 MO_F64_Sqrt -> fsLit "llvm.sqrt.f64"
430 MO_F64_Pwr -> fsLit "llvm.pow.f64"
432 MO_F64_Sin -> fsLit "llvm.sin.f64"
433 MO_F64_Cos -> fsLit "llvm.cos.f64"
434 MO_F64_Tan -> fsLit "tan"
436 MO_F64_Asin -> fsLit "asin"
437 MO_F64_Acos -> fsLit "acos"
438 MO_F64_Atan -> fsLit "atan"
440 MO_F64_Sinh -> fsLit "sinh"
441 MO_F64_Cosh -> fsLit "cosh"
442 MO_F64_Tanh -> fsLit "tanh"
444 MO_Memcpy -> fsLit $ "llvm.memcpy." ++ intrinTy1
445 MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1
446 MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2
448 a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")"
451 intrinTy1 = (if getLlvmVer env >= 28
452 then "p0i8.p0i8." else "") ++ show llvmWord
453 intrinTy2 = (if getLlvmVer env >= 28
454 then "p0i8." else "") ++ show llvmWord
457 -- | Tail function calls
458 genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData
460 -- Call to known function
461 genJump env (CmmLit (CmmLabel lbl)) = do
462 (env', vf, stmts, top) <- getHsFunc env lbl
463 (stgRegs, stgStmts) <- funEpilogue
464 let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
465 let s2 = Return Nothing
466 return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
469 -- Call to unknown function / address
470 genJump env expr = do
472 (env', vf, stmts, top) <- exprToVar env expr
474 let cast = case getVarType vf of
475 ty | isPointer ty -> LM_Bitcast
476 ty | isInt ty -> LM_Inttoptr
478 ty -> panic $ "genJump: Expr is of bad type for function call! ("
481 (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
482 (stgRegs, stgStmts) <- funEpilogue
483 let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
484 let s3 = Return Nothing
485 return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
489 -- | CmmAssign operation
491 -- We use stack allocated variables for CmmReg. The optimiser will replace
492 -- these with registers when possible.
493 genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData
494 genAssign env reg val = do
495 let (env1, vreg, stmts1, top1) = getCmmReg env reg
496 (env2, vval, stmts2, top2) <- exprToVar env1 val
497 let stmts = stmts1 `appOL` stmts2
499 let ty = (pLower . getVarType) vreg
500 case isPointer ty && getVarType vval == llvmWord of
501 -- Some registers are pointer types, so need to cast value to pointer
503 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
504 let s2 = Store v vreg
505 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
508 let s1 = Store vval vreg
509 return (env2, stmts `snocOL` s1, top1 ++ top2)
512 -- | CmmStore operation
513 genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
515 -- First we try to detect a few common cases and produce better code for
516 -- these then the default case. We are mostly trying to detect Cmm code
517 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
518 -- generic case that uses casts and pointer arithmetic
519 genStore env addr@(CmmReg (CmmGlobal r)) val
520 = genStore_fast env addr r 0 val
522 genStore env addr@(CmmRegOff (CmmGlobal r) n) val
523 = genStore_fast env addr r n val
525 genStore env addr@(CmmMachOp (MO_Add _) [
526 (CmmReg (CmmGlobal r)),
527 (CmmLit (CmmInt n _))])
529 = genStore_fast env addr r (fromInteger n) val
531 genStore env addr@(CmmMachOp (MO_Sub _) [
532 (CmmReg (CmmGlobal r)),
533 (CmmLit (CmmInt n _))])
535 = genStore_fast env addr r (negate $ fromInteger n) val
538 genStore env addr val = genStore_slow env addr val
540 -- | CmmStore operation
541 -- This is a special case for storing to a global register pointer
542 -- offset such as I32[Sp+8].
543 genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr
545 genStore_fast env addr r n val
546 = let gr = lmGlobalRegVar r
547 grt = (pLower . getVarType) gr
548 (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
549 in case isPointer grt && rem == 0 of
551 (env', vval, stmts, top) <- exprToVar env val
552 (gv, s1) <- doExpr grt $ Load gr
553 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
554 -- We might need a different pointer type, so check
555 case pLower grt == getVarType vval of
558 let s3 = Store vval ptr
559 return (env', stmts `snocOL` s1 `snocOL` s2
562 -- cast to pointer type needed
564 let ty = (pLift . getVarType) vval
565 (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
566 let s4 = Store vval ptr'
567 return (env', stmts `snocOL` s1 `snocOL` s2
568 `snocOL` s3 `snocOL` s4, top)
570 -- If its a bit type then we use the slow method since
571 -- we can't avoid casting anyway.
572 False -> genStore_slow env addr val
575 -- | CmmStore operation
576 -- Generic case. Uses casts and pointer arithmetic if needed.
577 genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
578 genStore_slow env addr val = do
579 (env1, vaddr, stmts1, top1) <- exprToVar env addr
580 (env2, vval, stmts2, top2) <- exprToVar env1 val
582 let stmts = stmts1 `appOL` stmts2
583 case getVarType vaddr of
584 -- sometimes we need to cast an int to a pointer before storing
585 LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do
586 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
587 let s2 = Store v vaddr
588 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
591 let s1 = Store vval vaddr
592 return (env2, stmts `snocOL` s1, top1 ++ top2)
594 i@(LMInt _) | i == llvmWord -> do
595 let vty = pLift $ getVarType vval
596 (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
597 let s2 = Store vval vptr
598 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
601 pprPanic "genStore: ptr not right type!"
602 (PprCmm.pprExpr addr <+> text (
603 "Size of Ptr: " ++ show llvmPtrBits ++
604 ", Size of var: " ++ show (llvmWidthInBits other) ++
605 ", Var: " ++ show vaddr))
608 -- | Unconditional branch
609 genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData
611 let label = blockIdToLlvm id
612 in return (env, unitOL $ Branch label, [])
615 -- | Conditional branch
616 genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData
617 genCondBranch env cond idT = do
619 let labelT = blockIdToLlvm idT
620 let labelF = LMLocalVar idF LMLabel
621 (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
622 if getVarType vc == i1
624 let s1 = BranchIf vc labelT labelF
626 return $ (env', stmts `snocOL` s1 `snocOL` s2, top)
628 panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
633 -- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
634 -- However, they may be defined one day, so we better document this behaviour.
635 genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
636 genSwitch env cond maybe_ids = do
637 (env', vc, stmts, top) <- exprToVar env cond
638 let ty = getVarType vc
640 let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ]
641 let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
642 -- out of range is undefied, so lets just branch to first label
643 let (_, defLbl) = head labels
645 let s1 = Switch vc defLbl labels
646 return $ (env', stmts `snocOL` s1, top)
649 -- -----------------------------------------------------------------------------
650 -- * CmmExpr code generation
653 -- | An expression conversion return data:
654 -- * LlvmEnv: The new enviornment
655 -- * LlvmVar: The var holding the result of the expression
656 -- * LlvmStatements: Any statements needed to evaluate the expression
657 -- * LlvmCmmTop: Any global data needed for this expression
658 type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmTop])
660 -- | Values which can be passed to 'exprToVar' to configure its
661 -- behaviour in certain circumstances.
662 data EOption = EOption {
663 -- | The expected LlvmType for the returned variable.
665 -- Currently just used for determining if a comparison should return
666 -- a boolean (i1) or a int (i32/i64).
667 eoExpectedType :: Maybe LlvmType
671 i1Option = EOption (Just i1)
673 wordOption :: EOption
674 wordOption = EOption (Just llvmWord)
677 -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
678 -- expression being stored in the returned LlvmVar.
679 exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
680 exprToVar env = exprToVarOpt env wordOption
682 exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
683 exprToVarOpt env opt e = case e of
691 -- Cmmreg in expression is the value, so must load. If you want actual
692 -- reg pointer, call getCmmReg directly.
694 let (env', vreg, stmts, top) = getCmmReg env r
695 (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg
696 case (isPointer . getVarType) v1 of
698 -- Cmm wants the value, so pointer types must be cast to ints
699 (v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord
700 return (env', v2, stmts `snocOL` s1 `snocOL` s2, top)
702 False -> return (env', v1, stmts `snocOL` s1, top)
705 -> genMachOp env opt op exprs
708 -> exprToVar env $ expandCmmReg (r, i)
711 -> panic "exprToVar: CmmStackSlot not supported!"
714 -- | Handle CmmMachOp expressions
715 genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
718 genMachOp env _ op [x] = case op of
721 let all1 = mkIntLit (widthToLlvmInt w) (-1)
722 in negate (widthToLlvmInt w) all1 LM_MO_Xor
725 let all0 = mkIntLit (widthToLlvmInt w) 0
726 in negate (widthToLlvmInt w) all0 LM_MO_Sub
729 let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
730 in negate (widthToLlvmFloat w) all0 LM_MO_FSub
732 MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
733 MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
736 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
739 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
742 -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
744 a -> panic $ "genMachOp: unmatched unary CmmMachOp! (" ++ show a ++ ")"
747 negate ty v2 negOp = do
748 (env', vx, stmts, top) <- exprToVar env x
749 (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
750 return (env', v1, stmts `snocOL` s1, top)
752 fiConv ty convOp = do
753 (env', vx, stmts, top) <- exprToVar env x
754 (v1, s1) <- doExpr ty $ Cast convOp vx ty
755 return (env', v1, stmts `snocOL` s1, top)
757 sameConv from ty reduce expand = do
758 x'@(env', vx, stmts, top) <- exprToVar env x
759 let sameConv' op = do
760 (v1, s1) <- doExpr ty $ Cast op vx ty
761 return (env', v1, stmts `snocOL` s1, top)
762 let toWidth = llvmWidthInBits ty
763 -- LLVM doesn't like trying to convert to same width, so
764 -- need to check for that as we do get Cmm code doing it.
765 case widthInBits from of
766 w | w < toWidth -> sameConv' expand
767 w | w > toWidth -> sameConv' reduce
770 -- Handle GlobalRegs pointers
771 genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
772 = genMachOp_fast env opt o r (fromInteger n) e
774 genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
775 = genMachOp_fast env opt o r (negate . fromInteger $ n) e
778 genMachOp env opt op e = genMachOp_slow env opt op e
781 -- | Handle CmmMachOp expressions
782 -- This is a specialised method that handles Global register manipulations like
783 -- 'Sp - 16', using the getelementptr instruction.
784 genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
786 genMachOp_fast env opt op r n e
787 = let gr = lmGlobalRegVar r
788 grt = (pLower . getVarType) gr
789 (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
790 in case isPointer grt && rem == 0 of
792 (gv, s1) <- doExpr grt $ Load gr
793 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
794 (var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord
795 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])
797 False -> genMachOp_slow env opt op e
800 -- | Handle CmmMachOp expressions
801 -- This handles all the cases not handle by the specialised genMachOp_fast.
802 genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
805 genMachOp_slow env opt op [x, y] = case op of
807 MO_Eq _ -> genBinComp opt LM_CMP_Eq
808 MO_Ne _ -> genBinComp opt LM_CMP_Ne
810 MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
811 MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
812 MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
813 MO_S_Le _ -> genBinComp opt LM_CMP_Sle
815 MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
816 MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
817 MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
818 MO_U_Le _ -> genBinComp opt LM_CMP_Ule
820 MO_Add _ -> genBinMach LM_MO_Add
821 MO_Sub _ -> genBinMach LM_MO_Sub
822 MO_Mul _ -> genBinMach LM_MO_Mul
824 MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
826 MO_S_MulMayOflo w -> isSMulOK w x y
828 MO_S_Quot _ -> genBinMach LM_MO_SDiv
829 MO_S_Rem _ -> genBinMach LM_MO_SRem
831 MO_U_Quot _ -> genBinMach LM_MO_UDiv
832 MO_U_Rem _ -> genBinMach LM_MO_URem
834 MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
835 MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
836 MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
837 MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
838 MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
839 MO_F_Le _ -> genBinComp opt LM_CMP_Fle
841 MO_F_Add _ -> genBinMach LM_MO_FAdd
842 MO_F_Sub _ -> genBinMach LM_MO_FSub
843 MO_F_Mul _ -> genBinMach LM_MO_FMul
844 MO_F_Quot _ -> genBinMach LM_MO_FDiv
846 MO_And _ -> genBinMach LM_MO_And
847 MO_Or _ -> genBinMach LM_MO_Or
848 MO_Xor _ -> genBinMach LM_MO_Xor
849 MO_Shl _ -> genBinMach LM_MO_Shl
850 MO_U_Shr _ -> genBinMach LM_MO_LShr
851 MO_S_Shr _ -> genBinMach LM_MO_AShr
853 a -> panic $ "genMachOp: unmatched binary CmmMachOp! (" ++ show a ++ ")"
856 binLlvmOp ty binOp = do
857 (env1, vx, stmts1, top1) <- exprToVar env x
858 (env2, vy, stmts2, top2) <- exprToVar env1 y
859 if getVarType vx == getVarType vy
861 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
862 return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1,
866 -- XXX: Error. Continue anyway so we can debug the generated
868 let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr)
869 let dx = Comment $ map fsLit $ cmmToStr x
870 let dy = Comment $ map fsLit $ cmmToStr y
871 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
872 let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
873 `snocOL` dy `snocOL` s1
874 return (env2, v1, allStmts, top1 ++ top2)
876 -- let o = case binOp vx vy of
877 -- Compare op _ _ -> show op
878 -- LlvmOp op _ _ -> show op
880 -- panic $ "genMachOp: comparison between different types ("
881 -- ++ o ++ " "++ show vx ++ ", " ++ show vy ++ ")"
882 -- ++ "\ne1: " ++ (show.llvmSDoc.PprCmm.pprExpr $ x)
883 -- ++ "\ne2: " ++ (show.llvmSDoc.PprCmm.pprExpr $ y)
885 -- | Need to use EOption here as Cmm expects word size results from
886 -- comparisons while LLVM return i1. Need to extend to llvmWord type
888 genBinComp opt cmp = do
889 ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) $ Compare cmp
891 if getVarType v1 == i1
893 case eoExpectedType opt of
901 (v2, s1) <- doExpr t $ Cast LM_Zext v1 t
902 return (env', v2, stmts `snocOL` s1, top)
905 panic $ "genBinComp: Can't case i1 compare"
906 ++ "res to non int type " ++ show (t)
908 panic $ "genBinComp: Compare returned type other then i1! "
909 ++ (show $ getVarType v1)
911 genBinMach op = binLlvmOp getVarType (LlvmOp op)
913 -- | Detect if overflow will occur in signed multiply of the two
914 -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
915 -- implementation. Its much longer due to type information/safety.
916 -- This should actually compile to only about 3 asm instructions.
917 isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData
919 (env1, vx, stmts1, top1) <- exprToVar env x
920 (env2, vy, stmts2, top2) <- exprToVar env1 y
922 let word = getVarType vx
923 let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx)
924 let shift = llvmWidthInBits word
925 let shift1 = toIWord (shift - 1)
926 let shift2 = toIWord shift
930 (x1, s1) <- doExpr word2 $ Cast LM_Sext vx word2
931 (y1, s2) <- doExpr word2 $ Cast LM_Sext vy word2
932 (r1, s3) <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
933 (rlow1, s4) <- doExpr word $ Cast LM_Trunc r1 word
934 (rlow2, s5) <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
935 (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
936 (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
937 (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
938 let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
939 `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
940 return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts,
944 panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"
946 -- More then two expression, invalid!
947 genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
950 -- | Handle CmmLoad expression.
951 genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
953 -- First we try to detect a few common cases and produce better code for
954 -- these then the default case. We are mostly trying to detect Cmm code
955 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
956 -- generic case that uses casts and pointer arithmetic
957 genLoad env e@(CmmReg (CmmGlobal r)) ty
958 = genLoad_fast env e r 0 ty
960 genLoad env e@(CmmRegOff (CmmGlobal r) n) ty
961 = genLoad_fast env e r n ty
963 genLoad env e@(CmmMachOp (MO_Add _) [
964 (CmmReg (CmmGlobal r)),
965 (CmmLit (CmmInt n _))])
967 = genLoad_fast env e r (fromInteger n) ty
969 genLoad env e@(CmmMachOp (MO_Sub _) [
970 (CmmReg (CmmGlobal r)),
971 (CmmLit (CmmInt n _))])
973 = genLoad_fast env e r (negate $ fromInteger n) ty
976 genLoad env e ty = genLoad_slow env e ty
978 -- | Handle CmmLoad expression.
979 -- This is a special case for loading from a global register pointer
980 -- offset such as I32[Sp+8].
981 genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
983 genLoad_fast env e r n ty =
984 let gr = lmGlobalRegVar r
985 grt = (pLower . getVarType) gr
986 ty' = cmmToLlvmType ty
987 (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
988 in case isPointer grt && rem == 0 of
990 (gv, s1) <- doExpr grt $ Load gr
991 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
992 -- We might need a different pointer type, so check
996 (var, s3) <- doExpr ty' $ Load ptr
997 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3,
1000 -- cast to pointer type needed
1003 (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
1004 (var, s4) <- doExpr ty' $ Load ptr'
1005 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3
1008 -- If its a bit type then we use the slow method since
1009 -- we can't avoid casting anyway.
1010 False -> genLoad_slow env e ty
1013 -- | Handle Cmm load expression.
1014 -- Generic case. Uses casts and pointer arithmetic if needed.
1015 genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
1016 genLoad_slow env e ty = do
1017 (env', iptr, stmts, tops) <- exprToVar env e
1018 case getVarType iptr of
1020 (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr
1021 return (env', dvar, stmts `snocOL` load, tops)
1023 i@(LMInt _) | i == llvmWord -> do
1024 let pty = LMPointer $ cmmToLlvmType ty
1025 (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty
1026 (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr
1027 return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
1029 other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
1030 (PprCmm.pprExpr e <+> text (
1031 "Size of Ptr: " ++ show llvmPtrBits ++
1032 ", Size of var: " ++ show (llvmWidthInBits other) ++
1033 ", Var: " ++ show iptr))
1036 -- | Handle CmmReg expression
1038 -- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an
1039 -- equivalent SSA form and avoids having to deal with Phi node insertion.
1040 -- This is also the approach recommended by LLVM developers.
1041 getCmmReg :: LlvmEnv -> CmmReg -> ExprData
1042 getCmmReg env r@(CmmLocal (LocalReg un _))
1043 = let exists = varLookup un env
1045 (newv, stmts) = allocReg r
1046 nenv = varInsert un (pLower $ getVarType newv) env
1048 Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, [])
1049 Nothing -> (nenv, newv, stmts, [])
1051 getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar g, nilOL, [])
1054 -- | Allocate a CmmReg on the stack
1055 allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
1056 allocReg (CmmLocal (LocalReg un ty))
1057 = let ty' = cmmToLlvmType ty
1058 var = LMLocalVar un (LMPointer ty')
1060 in (var, unitOL $ Assignment var alc)
1062 allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
1063 ++ " have been handled elsewhere!"
1066 -- | Generate code for a literal
1067 genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData
1068 genLit env (CmmInt i w)
1069 = return (env, mkIntLit (LMInt $ widthInBits w) i, nilOL, [])
1071 genLit env (CmmFloat r w)
1072 = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
1075 genLit env cmm@(CmmLabel l)
1076 = let label = strCLabel_llvm l
1077 ty = funLookup label env
1078 lmty = cmmToLlvmType $ cmmLitType cmm
1080 -- Make generic external label definition and then pointer to it
1082 let glob@(var, _) = genStringLabelRef label
1083 let ldata = [CmmData Data [([glob], [])]]
1084 let env' = funInsert label (pLower $ getVarType var) env
1085 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
1086 return (env', v1, unitOL s1, ldata)
1088 -- Referenced data exists in this module, retrieve type and make
1091 let var = LMGlobalVar label (LMPointer ty')
1092 ExternallyVisible Nothing Nothing False
1093 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
1094 return (env, v1, unitOL s1, [])
1096 genLit env (CmmLabelOff label off) = do
1097 (env', vlbl, stmts, stat) <- genLit env (CmmLabel label)
1098 let voff = toIWord off
1099 (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
1100 return (env', v1, stmts `snocOL` s1, stat)
1102 genLit env (CmmLabelDiffOff l1 l2 off) = do
1103 (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1)
1104 (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2)
1105 let voff = toIWord off
1106 let ty1 = getVarType vl1
1107 let ty2 = getVarType vl2
1108 if (isInt ty1) && (isInt ty2)
1109 && (llvmWidthInBits ty1 == llvmWidthInBits ty2)
1112 (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
1113 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
1114 return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
1118 panic "genLit: CmmLabelDiffOff encountered with different label ty!"
1120 genLit env (CmmBlock b)
1121 = genLit env (CmmLabel $ infoTblLbl b)
1123 genLit _ CmmHighStackMark
1124 = panic "genStaticLit - CmmHighStackMark unsupported!"
1127 -- -----------------------------------------------------------------------------
1131 -- | Function prologue. Load STG arguments into variables for function.
1132 funPrologue :: UniqSM [LlvmStatement]
1133 funPrologue = liftM concat $ mapM getReg activeStgRegs
1135 let reg = lmGlobalRegVar rr
1136 arg = lmGlobalRegArg rr
1137 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
1138 in return [alloc, Store arg reg]
1141 -- | Function epilogue. Load STG variables to use as argument for call.
1142 funEpilogue :: UniqSM ([LlvmVar], LlvmStatements)
1145 let reg = lmGlobalRegVar r
1146 (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
1147 return (v, unitOL s)
1148 loads <- mapM loadExpr activeStgRegs
1149 let (vars, stmts) = unzip loads
1150 return (vars, concatOL stmts)
1153 -- | A serries of statements to trash all the STG registers.
1155 -- In LLVM we pass the STG registers around everywhere in function calls.
1156 -- So this means LLVM considers them live across the entire function, when
1157 -- in reality they usually aren't. For Caller save registers across C calls
1158 -- the saving and restoring of them is done by the Cmm code generator,
1159 -- using Cmm local vars. So to stop LLVM saving them as well (and saving
1160 -- all of them since it thinks they're always live, we trash them just
1161 -- before the call by assigning the 'undef' value to them. The ones we
1162 -- need are restored from the Cmm local var and the ones we don't need
1163 -- are fine to be trashed.
1164 trashStmts :: LlvmStatements
1165 trashStmts = concatOL $ map trashReg activeStgRegs
1167 let reg = lmGlobalRegVar r
1168 ty = (pLower . getVarType) reg
1169 trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
1170 in case callerSaves r of
1175 -- | Get a function pointer to the CLabel specified.
1177 -- This is for Haskell functions, function type is assumed, so doesn't work
1178 -- with foreign functions.
1179 getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData
1181 = let fn = strCLabel_llvm lbl
1182 ty = funLookup fn env
1184 -- Function in module in right form
1185 Just ty'@(LMFunction sig) -> do
1186 let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False
1187 return (env, fun, nilOL, [])
1189 -- label in module but not function pointer, convert
1191 let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
1192 Nothing Nothing False
1193 (v1, s1) <- doExpr (pLift llvmFunTy) $
1194 Cast LM_Bitcast fun (pLift llvmFunTy)
1195 return (env, v1, unitOL s1, [])
1197 -- label not in module, create external reference
1199 let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible
1200 let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
1201 let top = CmmData Data [([],[ty'])]
1202 let env' = funInsert fn ty' env
1203 return (env', fun, nilOL, [top])
1206 -- | Create a new local var
1207 mkLocalVar :: LlvmType -> UniqSM LlvmVar
1210 return $ LMLocalVar un ty
1213 -- | Execute an expression, assigning result to a var
1214 doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement)
1217 return (v, Assignment v expr)
1220 -- | Expand CmmRegOff
1221 expandCmmReg :: (CmmReg, Int) -> CmmExpr
1222 expandCmmReg (reg, off)
1223 = let width = typeWidth (cmmRegType reg)
1224 voff = CmmLit $ CmmInt (fromIntegral off) width
1225 in CmmMachOp (MO_Add width) [CmmReg reg, voff]
1228 -- | Convert a block id into a appropriate Llvm label
1229 blockIdToLlvm :: BlockId -> LlvmVar
1230 blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
1232 -- | Create Llvm int Literal
1233 mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
1234 mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
1236 -- | Convert int type to a LLvmVar of word or i32 size
1237 toI32, toIWord :: Integral a => a -> LlvmVar
1238 toI32 = mkIntLit i32
1239 toIWord = mkIntLit llvmWord
1242 -- | Error functions
1243 panic :: String -> a
1244 panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
1246 pprPanic :: String -> SDoc -> a
1247 pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d