1 -- ----------------------------------------------------------------------------
2 -- | Handle conversion of CmmProc to LLVM code.
5 module LlvmCodeGen.CodeGen ( genLlvmProc ) where
7 #include "HsVersions.h"
10 import LlvmCodeGen.Base
11 import LlvmCodeGen.Regs
14 import CgUtils ( activeStgRegs, callerSaves )
17 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 -> HintedCmmFormals -> HintedCmmActuals
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 = LMLitVar $ LMIntLit (-1) i1
181 -- Handle all other foreign calls and prim ops.
182 genCall env target res args ret = do
185 let arg_type (CmmHinted _ AddrHint) = i8Ptr
186 -- cast pointers to i8*. Llvm equivalent of void*
187 arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType expr
190 let ret_type ([]) = LMVoid
191 ret_type ([CmmHinted _ AddrHint]) = i8Ptr
192 ret_type ([CmmHinted reg _]) = cmmToLlvmType $ localRegType reg
193 ret_type t = panic $ "genCall: Too many return values! Can only handle"
194 ++ " 0 or 1, given " ++ show (length t) ++ "."
196 -- extract Cmm call convention
197 let cconv = case target of
198 CmmCallee _ conv -> conv
199 CmmPrim _ -> PrimCallConv
201 -- translate to LLVM call convention
202 let lmconv = case cconv of
203 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
204 StdCallConv -> CC_X86_Stdcc
206 StdCallConv -> CC_Ccc
209 PrimCallConv -> CC_Ccc
210 CmmCallConv -> panic "CmmCallConv not supported here!"
213 Some of the possibilities here are a worry with the use of a custom
214 calling convention for passing STG args. In practice the more
215 dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
217 The native code generator only handles StdCall and CCallConv.
221 let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs
222 | otherwise = llvmStdFunAttrs
225 let ccTy = StdCall -- tail calls should be done through CmmJump
226 let retTy = ret_type res
227 let argTy = tysToParams $ map arg_type args
228 let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible
229 lmconv retTy FixedArgs argTy llvmFunAlign
231 -- get parameter values
232 (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
234 -- get the return register
235 let ret_reg ([CmmHinted reg hint]) = (reg, hint)
236 ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
237 ++ " 1, given " ++ show (length t) ++ "."
239 -- deal with call types
240 let getFunPtr :: CmmCallTarget -> UniqSM ExprData
241 getFunPtr targ = case targ of
242 CmmCallee (CmmLit (CmmLabel lbl)) _ -> do
243 let name = strCLabel_llvm lbl
244 case funLookup name env1 of
245 Just ty'@(LMFunction sig) -> do
246 -- Function in module in right form
247 let fun = LMGlobalVar name ty' (funcLinkage sig)
248 Nothing Nothing False
249 return (env1, fun, nilOL, [])
252 -- label in module but not function pointer, convert
253 let fty@(LMFunction sig) = funTy name
254 let fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
255 Nothing Nothing False
256 (v1, s1) <- doExpr (pLift fty)
257 $ Cast LM_Bitcast fun (pLift fty)
258 return (env1, v1, unitOL s1, [])
261 -- label not in module, create external reference
262 let fty@(LMFunction sig) = funTy name
263 let fun = LMGlobalVar name fty (funcLinkage sig)
264 Nothing Nothing False
265 let top = CmmData Data [([],[fty])]
266 let env' = funInsert name fty env1
267 return (env', fun, nilOL, [top])
269 CmmCallee expr _ -> do
270 (env', v1, stmts, top) <- exprToVar env1 expr
271 let fty = funTy $ fsLit "dynamic"
272 let cast = case getVarType v1 of
273 ty | isPointer ty -> LM_Bitcast
274 ty | isInt ty -> LM_Inttoptr
276 ty -> panic $ "genCall: Expr is of bad type for function"
277 ++ " call! (" ++ show (ty) ++ ")"
279 (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
280 return (env', v2, stmts `snocOL` s1, top)
283 let name = cmmPrimOpFunctions mop
284 let lbl = mkForeignLabel name Nothing
285 ForeignLabelInExternalPackage IsFunction
286 getFunPtr $ CmmCallee (CmmLit (CmmLabel lbl)) CCallConv
288 (env2, fptr, stmts2, top2) <- getFunPtr target
290 let retStmt | ccTy == TailCall = unitOL $ Return Nothing
291 | ret == CmmNeverReturns = unitOL $ Unreachable
294 {- In LLVM we pass the STG registers around everywhere in function calls.
295 So this means LLVM considers them live across the entire function, when
296 in reality they usually aren't. For Caller save registers across C calls
297 the saving and restoring of them is done by the Cmm code generator,
298 using Cmm local vars. So to stop LLVM saving them as well (and saving
299 all of them since it thinks they're always live, we trash them just
300 before the call by assigning the 'undef' value to them. The ones we
301 need are restored from the Cmm local var and the ones we don't need
302 are fine to be trashed.
304 let trashStmts = concatOL $ map trashReg activeStgRegs
306 let reg = lmGlobalRegVar r
307 ty = (pLower . getVarType) reg
308 trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
309 in case callerSaves r of
313 let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts
315 -- make the actual call
318 let s1 = Expr $ Call ccTy fptr argVars fnAttrs
319 let allStmts = stmts `snocOL` s1 `appOL` retStmt
320 return (env2, allStmts, top1 ++ top2)
323 (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
324 let (creg, _) = ret_reg res
325 let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
326 let allStmts = stmts `snocOL` s1 `appOL` stmts3
327 if retTy == pLower (getVarType vreg)
329 let s2 = Store v1 vreg
330 return (env3, allStmts `snocOL` s2 `appOL` retStmt,
331 top1 ++ top2 ++ top3)
333 let ty = pLower $ getVarType vreg
335 vt | isPointer vt -> LM_Bitcast
336 | isInt vt -> LM_Ptrtoint
338 panic $ "genCall: CmmReg bad match for"
341 (v2, s2) <- doExpr ty $ Cast op v1 ty
342 let s3 = Store v2 vreg
343 return (env3, allStmts `snocOL` s2 `snocOL` s3
344 `appOL` retStmt, top1 ++ top2 ++ top3)
347 -- | Conversion of call arguments.
350 -> ([LlvmVar], LlvmStatements, [LlvmCmmTop])
351 -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmTop])
353 arg_vars env [] (vars, stmts, tops)
354 = return (env, vars, stmts, tops)
356 arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
357 = do (env', v1, stmts', top') <- exprToVar env e
358 let op = case getVarType v1 of
359 ty | isPointer ty -> LM_Bitcast
360 ty | isInt ty -> LM_Inttoptr
362 a -> panic $ "genCall: Can't cast llvmType to i8*! ("
365 (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
366 arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
369 arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
370 = do (env', v1, stmts', top') <- exprToVar env e
371 arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
373 -- | Decide what C function to use to implement a CallishMachOp
374 cmmPrimOpFunctions :: CallishMachOp -> FastString
375 cmmPrimOpFunctions mop
377 MO_F32_Exp -> fsLit "expf"
378 MO_F32_Log -> fsLit "logf"
379 MO_F32_Sqrt -> fsLit "llvm.sqrt.f32"
380 MO_F32_Pwr -> fsLit "llvm.pow.f32"
382 MO_F32_Sin -> fsLit "llvm.sin.f32"
383 MO_F32_Cos -> fsLit "llvm.cos.f32"
384 MO_F32_Tan -> fsLit "tanf"
386 MO_F32_Asin -> fsLit "asinf"
387 MO_F32_Acos -> fsLit "acosf"
388 MO_F32_Atan -> fsLit "atanf"
390 MO_F32_Sinh -> fsLit "sinhf"
391 MO_F32_Cosh -> fsLit "coshf"
392 MO_F32_Tanh -> fsLit "tanhf"
394 MO_F64_Exp -> fsLit "exp"
395 MO_F64_Log -> fsLit "log"
396 MO_F64_Sqrt -> fsLit "llvm.sqrt.f64"
397 MO_F64_Pwr -> fsLit "llvm.pow.f64"
399 MO_F64_Sin -> fsLit "llvm.sin.f64"
400 MO_F64_Cos -> fsLit "llvm.cos.f64"
401 MO_F64_Tan -> fsLit "tan"
403 MO_F64_Asin -> fsLit "asin"
404 MO_F64_Acos -> fsLit "acos"
405 MO_F64_Atan -> fsLit "atan"
407 MO_F64_Sinh -> fsLit "sinh"
408 MO_F64_Cosh -> fsLit "cosh"
409 MO_F64_Tanh -> fsLit "tanh"
411 a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")"
414 -- | Tail function calls
415 genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData
417 -- Call to known function
418 genJump env (CmmLit (CmmLabel lbl)) = do
419 (env', vf, stmts, top) <- getHsFunc env lbl
420 (stgRegs, stgStmts) <- funEpilogue
421 let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
422 let s2 = Return Nothing
423 return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
426 -- Call to unknown function / address
427 genJump env expr = do
429 (env', vf, stmts, top) <- exprToVar env expr
431 let cast = case getVarType vf of
432 ty | isPointer ty -> LM_Bitcast
433 ty | isInt ty -> LM_Inttoptr
435 ty -> panic $ "genJump: Expr is of bad type for function call! ("
438 (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
439 (stgRegs, stgStmts) <- funEpilogue
440 let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
441 let s3 = Return Nothing
442 return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
446 -- | CmmAssign operation
448 -- We use stack allocated variables for CmmReg. The optimiser will replace
449 -- these with registers when possible.
450 genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData
451 genAssign env reg val = do
452 let (env1, vreg, stmts1, top1) = getCmmReg env reg
453 (env2, vval, stmts2, top2) <- exprToVar env1 val
454 let stmts = stmts1 `appOL` stmts2
456 let ty = (pLower . getVarType) vreg
457 case isPointer ty && getVarType vval == llvmWord of
458 -- Some registers are pointer types, so need to cast value to pointer
460 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
461 let s2 = Store v vreg
462 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
465 let s1 = Store vval vreg
466 return (env2, stmts `snocOL` s1, top1 ++ top2)
469 -- | CmmStore operation
470 genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
472 -- First we try to detect a few common cases and produce better code for
473 -- these then the default case. We are mostly trying to detect Cmm code
474 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
475 -- generic case that uses casts and pointer arithmetic
476 genStore env addr@(CmmReg (CmmGlobal r)) val
477 = genStore_fast env addr r 0 val
479 genStore env addr@(CmmRegOff (CmmGlobal r) n) val
480 = genStore_fast env addr r n val
482 genStore env addr@(CmmMachOp (MO_Add _) [
483 (CmmReg (CmmGlobal r)),
484 (CmmLit (CmmInt n _))])
486 = genStore_fast env addr r (fromInteger n) val
488 genStore env addr@(CmmMachOp (MO_Sub _) [
489 (CmmReg (CmmGlobal r)),
490 (CmmLit (CmmInt n _))])
492 = genStore_fast env addr r (negate $ fromInteger n) val
495 genStore env addr val = genStore_slow env addr val
497 -- | CmmStore operation
498 -- This is a special case for storing to a global register pointer
499 -- offset such as I32[Sp+8].
500 genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr
502 genStore_fast env addr r n val
503 = let gr = lmGlobalRegVar r
504 grt = (pLower . getVarType) gr
505 (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
506 in case isPointer grt && rem == 0 of
508 (env', vval, stmts, top) <- exprToVar env val
509 (gv, s1) <- doExpr grt $ Load gr
510 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
511 -- We might need a different pointer type, so check
512 case pLower grt == getVarType vval of
515 let s3 = Store vval ptr
516 return (env', stmts `snocOL` s1 `snocOL` s2
519 -- cast to pointer type needed
521 let ty = (pLift . getVarType) vval
522 (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
523 let s4 = Store vval ptr'
524 return (env', stmts `snocOL` s1 `snocOL` s2
525 `snocOL` s3 `snocOL` s4, top)
527 -- If its a bit type then we use the slow method since
528 -- we can't avoid casting anyway.
529 False -> genStore_slow env addr val
532 -- | CmmStore operation
533 -- Generic case. Uses casts and pointer arithmetic if needed.
534 genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
535 genStore_slow env addr val = do
536 (env1, vaddr, stmts1, top1) <- exprToVar env addr
537 (env2, vval, stmts2, top2) <- exprToVar env1 val
539 let stmts = stmts1 `appOL` stmts2
540 case getVarType vaddr of
541 -- sometimes we need to cast an int to a pointer before storing
542 LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do
543 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
544 let s2 = Store v vaddr
545 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
548 let s1 = Store vval vaddr
549 return (env2, stmts `snocOL` s1, top1 ++ top2)
551 i@(LMInt _) | i == llvmWord -> do
552 let vty = pLift $ getVarType vval
553 (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
554 let s2 = Store vval vptr
555 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
558 pprPanic "genStore: ptr not right type!"
559 (PprCmm.pprExpr addr <+> text (
560 "Size of Ptr: " ++ show llvmPtrBits ++
561 ", Size of var: " ++ show (llvmWidthInBits other) ++
562 ", Var: " ++ show vaddr))
565 -- | Unconditional branch
566 genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData
568 let label = blockIdToLlvm id
569 in return (env, unitOL $ Branch label, [])
572 -- | Conditional branch
573 genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData
574 genCondBranch env cond idT = do
576 let labelT = blockIdToLlvm idT
577 let labelF = LMLocalVar idF LMLabel
578 (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
579 if getVarType vc == i1
581 let s1 = BranchIf vc labelT labelF
583 return $ (env', stmts `snocOL` s1 `snocOL` s2, top)
585 panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
590 -- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
591 -- However, they may be defined one day, so we better document this behaviour.
592 genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
593 genSwitch env cond maybe_ids = do
594 (env', vc, stmts, top) <- exprToVar env cond
595 let ty = getVarType vc
597 let pairs = [ (ix, id) | (ix,Just id) <- zip ([0..]::[Integer]) maybe_ids ]
598 let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
599 -- out of range is undefied, so lets just branch to first label
600 let (_, defLbl) = head labels
602 let s1 = Switch vc defLbl labels
603 return $ (env', stmts `snocOL` s1, top)
606 -- -----------------------------------------------------------------------------
607 -- * CmmExpr code generation
610 -- | An expression conversion return data:
611 -- * LlvmEnv: The new enviornment
612 -- * LlvmVar: The var holding the result of the expression
613 -- * LlvmStatements: Any statements needed to evaluate the expression
614 -- * LlvmCmmTop: Any global data needed for this expression
615 type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmTop])
617 -- | Values which can be passed to 'exprToVar' to configure its
618 -- behaviour in certain circumstances.
619 data EOption = EOption {
620 -- | The expected LlvmType for the returned variable.
622 -- Currently just used for determining if a comparison should return
623 -- a boolean (i1) or a int (i32/i64).
624 eoExpectedType :: Maybe LlvmType
628 i1Option = EOption (Just i1)
630 wordOption :: EOption
631 wordOption = EOption (Just llvmWord)
634 -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
635 -- expression being stored in the returned LlvmVar.
636 exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
637 exprToVar env = exprToVarOpt env wordOption
639 exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
640 exprToVarOpt env opt e = case e of
648 -- Cmmreg in expression is the value, so must load. If you want actual
649 -- reg pointer, call getCmmReg directly.
651 let (env', vreg, stmts, top) = getCmmReg env r
652 (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg
653 case (isPointer . getVarType) v1 of
655 -- Cmm wants the value, so pointer types must be cast to ints
656 (v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord
657 return (env', v2, stmts `snocOL` s1 `snocOL` s2, top)
659 False -> return (env', v1, stmts `snocOL` s1, top)
662 -> genMachOp env opt op exprs
665 -> exprToVar env $ expandCmmReg (r, i)
668 -> panic "exprToVar: CmmStackSlot not supported!"
671 -- | Handle CmmMachOp expressions
672 genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
675 genMachOp env _ op [x] = case op of
678 let all1 = mkIntLit (widthToLlvmInt w) (-1::Int)
679 in negate (widthToLlvmInt w) all1 LM_MO_Xor
682 let all0 = mkIntLit (widthToLlvmInt w) (0::Int)
683 in negate (widthToLlvmInt w) all0 LM_MO_Sub
686 let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
687 in negate (widthToLlvmFloat w) all0 LM_MO_FSub
689 MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
690 MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
693 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
696 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
699 -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
701 a -> panic $ "genMachOp: unmatched unary CmmMachOp! (" ++ show a ++ ")"
704 negate ty v2 negOp = do
705 (env', vx, stmts, top) <- exprToVar env x
706 (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
707 return (env', v1, stmts `snocOL` s1, top)
709 fiConv ty convOp = do
710 (env', vx, stmts, top) <- exprToVar env x
711 (v1, s1) <- doExpr ty $ Cast convOp vx ty
712 return (env', v1, stmts `snocOL` s1, top)
714 sameConv from ty reduce expand = do
715 x'@(env', vx, stmts, top) <- exprToVar env x
716 let sameConv' op = do
717 (v1, s1) <- doExpr ty $ Cast op vx ty
718 return (env', v1, stmts `snocOL` s1, top)
719 let toWidth = llvmWidthInBits ty
720 -- LLVM doesn't like trying to convert to same width, so
721 -- need to check for that as we do get Cmm code doing it.
722 case widthInBits from of
723 w | w < toWidth -> sameConv' expand
724 w | w > toWidth -> sameConv' reduce
727 -- Handle GlobalRegs pointers
728 genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
729 = genMachOp_fast env opt o r (fromInteger n) e
731 genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
732 = genMachOp_fast env opt o r (negate . fromInteger $ n) e
735 genMachOp env opt op e = genMachOp_slow env opt op e
738 -- | Handle CmmMachOp expressions
739 -- This is a specialised method that handles Global register manipulations like
740 -- 'Sp - 16', using the getelementptr instruction.
741 genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
743 genMachOp_fast env opt op r n e
744 = let gr = lmGlobalRegVar r
745 grt = (pLower . getVarType) gr
746 (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
747 in case isPointer grt && rem == 0 of
749 (gv, s1) <- doExpr grt $ Load gr
750 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
751 (var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord
752 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])
754 False -> genMachOp_slow env opt op e
757 -- | Handle CmmMachOp expressions
758 -- This handles all the cases not handle by the specialised genMachOp_fast.
759 genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
762 genMachOp_slow env opt op [x, y] = case op of
764 MO_Eq _ -> genBinComp opt LM_CMP_Eq
765 MO_Ne _ -> genBinComp opt LM_CMP_Ne
767 MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
768 MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
769 MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
770 MO_S_Le _ -> genBinComp opt LM_CMP_Sle
772 MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
773 MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
774 MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
775 MO_U_Le _ -> genBinComp opt LM_CMP_Ule
777 MO_Add _ -> genBinMach LM_MO_Add
778 MO_Sub _ -> genBinMach LM_MO_Sub
779 MO_Mul _ -> genBinMach LM_MO_Mul
781 MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
783 MO_S_MulMayOflo w -> isSMulOK w x y
785 MO_S_Quot _ -> genBinMach LM_MO_SDiv
786 MO_S_Rem _ -> genBinMach LM_MO_SRem
788 MO_U_Quot _ -> genBinMach LM_MO_UDiv
789 MO_U_Rem _ -> genBinMach LM_MO_URem
791 MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
792 MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
793 MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
794 MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
795 MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
796 MO_F_Le _ -> genBinComp opt LM_CMP_Fle
798 MO_F_Add _ -> genBinMach LM_MO_FAdd
799 MO_F_Sub _ -> genBinMach LM_MO_FSub
800 MO_F_Mul _ -> genBinMach LM_MO_FMul
801 MO_F_Quot _ -> genBinMach LM_MO_FDiv
803 MO_And _ -> genBinMach LM_MO_And
804 MO_Or _ -> genBinMach LM_MO_Or
805 MO_Xor _ -> genBinMach LM_MO_Xor
806 MO_Shl _ -> genBinMach LM_MO_Shl
807 MO_U_Shr _ -> genBinMach LM_MO_LShr
808 MO_S_Shr _ -> genBinMach LM_MO_AShr
810 a -> panic $ "genMachOp: unmatched binary CmmMachOp! (" ++ show a ++ ")"
813 binLlvmOp ty binOp = do
814 (env1, vx, stmts1, top1) <- exprToVar env x
815 (env2, vy, stmts2, top2) <- exprToVar env1 y
816 if getVarType vx == getVarType vy
818 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
819 return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1,
823 -- XXX: Error. Continue anyway so we can debug the generated
825 let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr)
826 let dx = Comment $ map fsLit $ cmmToStr x
827 let dy = Comment $ map fsLit $ cmmToStr y
828 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
829 let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
830 `snocOL` dy `snocOL` s1
831 return (env2, v1, allStmts, top1 ++ top2)
833 -- let o = case binOp vx vy of
834 -- Compare op _ _ -> show op
835 -- LlvmOp op _ _ -> show op
837 -- panic $ "genMachOp: comparison between different types ("
838 -- ++ o ++ " "++ show vx ++ ", " ++ show vy ++ ")"
839 -- ++ "\ne1: " ++ (show.llvmSDoc.PprCmm.pprExpr $ x)
840 -- ++ "\ne2: " ++ (show.llvmSDoc.PprCmm.pprExpr $ y)
842 -- | Need to use EOption here as Cmm expects word size results from
843 -- comparisons while LLVM return i1. Need to extend to llvmWord type
845 genBinComp opt cmp = do
846 ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) $ Compare cmp
848 if getVarType v1 == i1
850 case eoExpectedType opt of
858 (v2, s1) <- doExpr t $ Cast LM_Zext v1 t
859 return (env', v2, stmts `snocOL` s1, top)
862 panic $ "genBinComp: Can't case i1 compare"
863 ++ "res to non int type " ++ show (t)
865 panic $ "genBinComp: Compare returned type other then i1! "
866 ++ (show $ getVarType v1)
868 genBinMach op = binLlvmOp getVarType (LlvmOp op)
870 -- | Detect if overflow will occur in signed multiply of the two
871 -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
872 -- implementation. Its much longer due to type information/safety.
873 -- This should actually compile to only about 3 asm instructions.
874 isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData
876 (env1, vx, stmts1, top1) <- exprToVar env x
877 (env2, vy, stmts2, top2) <- exprToVar env1 y
879 let word = getVarType vx
880 let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx)
881 let shift = llvmWidthInBits word
882 let shift1 = toIWord (shift - 1)
883 let shift2 = toIWord shift
887 (x1, s1) <- doExpr word2 $ Cast LM_Sext vx word2
888 (y1, s2) <- doExpr word2 $ Cast LM_Sext vy word2
889 (r1, s3) <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
890 (rlow1, s4) <- doExpr word $ Cast LM_Trunc r1 word
891 (rlow2, s5) <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
892 (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
893 (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
894 (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
895 let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
896 `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
897 return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts,
901 panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"
903 -- More then two expression, invalid!
904 genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
907 -- | Handle CmmLoad expression.
908 genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
910 -- First we try to detect a few common cases and produce better code for
911 -- these then the default case. We are mostly trying to detect Cmm code
912 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
913 -- generic case that uses casts and pointer arithmetic
914 genLoad env e@(CmmReg (CmmGlobal r)) ty
915 = genLoad_fast env e r 0 ty
917 genLoad env e@(CmmRegOff (CmmGlobal r) n) ty
918 = genLoad_fast env e r n ty
920 genLoad env e@(CmmMachOp (MO_Add _) [
921 (CmmReg (CmmGlobal r)),
922 (CmmLit (CmmInt n _))])
924 = genLoad_fast env e r (fromInteger n) ty
926 genLoad env e@(CmmMachOp (MO_Sub _) [
927 (CmmReg (CmmGlobal r)),
928 (CmmLit (CmmInt n _))])
930 = genLoad_fast env e r (negate $ fromInteger n) ty
933 genLoad env e ty = genLoad_slow env e ty
935 -- | Handle CmmLoad expression.
936 -- This is a special case for loading from a global register pointer
937 -- offset such as I32[Sp+8].
938 genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
940 genLoad_fast env e r n ty =
941 let gr = lmGlobalRegVar r
942 grt = (pLower . getVarType) gr
943 ty' = cmmToLlvmType ty
944 (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
945 in case isPointer grt && rem == 0 of
947 (gv, s1) <- doExpr grt $ Load gr
948 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
949 -- We might need a different pointer type, so check
953 (var, s3) <- doExpr ty' $ Load ptr
954 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3,
957 -- cast to pointer type needed
960 (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
961 (var, s4) <- doExpr ty' $ Load ptr'
962 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3
965 -- If its a bit type then we use the slow method since
966 -- we can't avoid casting anyway.
967 False -> genLoad_slow env e ty
970 -- | Handle Cmm load expression.
971 -- Generic case. Uses casts and pointer arithmetic if needed.
972 genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
973 genLoad_slow env e ty = do
974 (env', iptr, stmts, tops) <- exprToVar env e
975 case getVarType iptr of
977 (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr
978 return (env', dvar, stmts `snocOL` load, tops)
980 i@(LMInt _) | i == llvmWord -> do
981 let pty = LMPointer $ cmmToLlvmType ty
982 (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty
983 (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr
984 return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
986 other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
987 (PprCmm.pprExpr e <+> text (
988 "Size of Ptr: " ++ show llvmPtrBits ++
989 ", Size of var: " ++ show (llvmWidthInBits other) ++
990 ", Var: " ++ show iptr))
993 -- | Handle CmmReg expression
995 -- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an
996 -- equivalent SSA form and avoids having to deal with Phi node insertion.
997 -- This is also the approach recommended by LLVM developers.
998 getCmmReg :: LlvmEnv -> CmmReg -> ExprData
999 getCmmReg env r@(CmmLocal (LocalReg un _))
1000 = let exists = varLookup un env
1002 (newv, stmts) = allocReg r
1003 nenv = varInsert un (pLower $ getVarType newv) env
1005 Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, [])
1006 Nothing -> (nenv, newv, stmts, [])
1008 getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar g, nilOL, [])
1011 -- | Allocate a CmmReg on the stack
1012 allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
1013 allocReg (CmmLocal (LocalReg un ty))
1014 = let ty' = cmmToLlvmType ty
1015 var = LMLocalVar un (LMPointer ty')
1017 in (var, unitOL $ Assignment var alc)
1019 allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
1020 ++ " have been handled elsewhere!"
1023 -- | Generate code for a literal
1024 genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData
1025 genLit env (CmmInt i w)
1026 = return (env, mkIntLit (LMInt $ widthInBits w) i, nilOL, [])
1028 genLit env (CmmFloat r w)
1029 = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
1032 genLit env cmm@(CmmLabel l)
1033 = let label = strCLabel_llvm l
1034 ty = funLookup label env
1035 lmty = cmmToLlvmType $ cmmLitType cmm
1037 -- Make generic external label definition and then pointer to it
1039 let glob@(var, _) = genStringLabelRef label
1040 let ldata = [CmmData Data [([glob], [])]]
1041 let env' = funInsert label (pLower $ getVarType var) env
1042 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
1043 return (env', v1, unitOL s1, ldata)
1045 -- Referenced data exists in this module, retrieve type and make
1048 let var = LMGlobalVar label (LMPointer ty')
1049 ExternallyVisible Nothing Nothing False
1050 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
1051 return (env, v1, unitOL s1, [])
1053 genLit env (CmmLabelOff label off) = do
1054 (env', vlbl, stmts, stat) <- genLit env (CmmLabel label)
1055 let voff = toIWord off
1056 (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
1057 return (env', v1, stmts `snocOL` s1, stat)
1059 genLit env (CmmLabelDiffOff l1 l2 off) = do
1060 (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1)
1061 (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2)
1062 let voff = toIWord off
1063 let ty1 = getVarType vl1
1064 let ty2 = getVarType vl2
1065 if (isInt ty1) && (isInt ty2)
1066 && (llvmWidthInBits ty1 == llvmWidthInBits ty2)
1069 (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
1070 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
1071 return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
1075 panic "genLit: CmmLabelDiffOff encountered with different label ty!"
1077 genLit env (CmmBlock b)
1078 = genLit env (CmmLabel $ infoTblLbl b)
1080 genLit _ CmmHighStackMark
1081 = panic "genStaticLit - CmmHighStackMark unsupported!"
1084 -- -----------------------------------------------------------------------------
1088 -- | Function prologue. Load STG arguments into variables for function.
1089 funPrologue :: UniqSM [LlvmStatement]
1090 funPrologue = liftM concat $ mapM getReg activeStgRegs
1092 let reg = lmGlobalRegVar rr
1093 arg = lmGlobalRegArg rr
1094 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
1095 in return [alloc, Store arg reg]
1098 -- | Function epilogue. Load STG variables to use as argument for call.
1099 funEpilogue :: UniqSM ([LlvmVar], LlvmStatements)
1102 let reg = lmGlobalRegVar r
1103 (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
1104 return (v, unitOL s)
1105 loads <- mapM loadExpr activeStgRegs
1106 let (vars, stmts) = unzip loads
1107 return (vars, concatOL stmts)
1110 -- | Get a function pointer to the CLabel specified.
1112 -- This is for Haskell functions, function type is assumed, so doesn't work
1113 -- with foreign functions.
1114 getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData
1116 = let fn = strCLabel_llvm lbl
1117 ty = funLookup fn env
1119 -- Function in module in right form
1120 Just ty'@(LMFunction sig) -> do
1121 let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False
1122 return (env, fun, nilOL, [])
1124 -- label in module but not function pointer, convert
1126 let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
1127 Nothing Nothing False
1128 (v1, s1) <- doExpr (pLift llvmFunTy) $
1129 Cast LM_Bitcast fun (pLift llvmFunTy)
1130 return (env, v1, unitOL s1, [])
1132 -- label not in module, create external reference
1134 let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible
1135 let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
1136 let top = CmmData Data [([],[ty'])]
1137 let env' = funInsert fn ty' env
1138 return (env', fun, nilOL, [top])
1141 -- | Create a new local var
1142 mkLocalVar :: LlvmType -> UniqSM LlvmVar
1145 return $ LMLocalVar un ty
1148 -- | Execute an expression, assigning result to a var
1149 doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement)
1152 return (v, Assignment v expr)
1155 -- | Expand CmmRegOff
1156 expandCmmReg :: (CmmReg, Int) -> CmmExpr
1157 expandCmmReg (reg, off)
1158 = let width = typeWidth (cmmRegType reg)
1159 voff = CmmLit $ CmmInt (fromIntegral off) width
1160 in CmmMachOp (MO_Add width) [CmmReg reg, voff]
1163 -- | Convert a block id into a appropriate Llvm label
1164 blockIdToLlvm :: BlockId -> LlvmVar
1165 blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
1167 -- | Create Llvm int Literal
1168 mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
1169 mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
1171 -- | Convert int type to a LLvmVar of word or i32 size
1172 toI32, toIWord :: Integral a => a -> LlvmVar
1173 toI32 = mkIntLit i32
1174 toIWord = mkIntLit llvmWord
1177 -- | Error functions
1178 panic :: String -> a
1179 panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
1181 pprPanic :: String -> SDoc -> a
1182 pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d