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 PprCmm
23 import Outputable hiding ( panic, pprPanic )
24 import qualified Outputable
29 import Control.Monad ( liftM )
31 type LlvmStatements = OrdList LlvmStatement
33 -- -----------------------------------------------------------------------------
34 -- | Top-level of the LLVM proc Code generator
36 genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop])
37 genLlvmProc env (CmmData _ _)
40 genLlvmProc env (CmmProc _ _ _ (ListGraph []))
43 genLlvmProc env (CmmProc info lbl params (ListGraph blocks))
45 (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
47 let proc = CmmProc info lbl params (ListGraph lmblocks)
48 let tops = lmdata ++ [proc]
53 -- -----------------------------------------------------------------------------
54 -- * Block code generation
57 -- | Generate code for a list of blocks that make up a complete procedure.
58 basicBlocksCodeGen :: LlvmEnv
60 -> ( [LlvmBasicBlock] , [LlvmCmmTop] )
61 -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmTop] )
62 basicBlocksCodeGen env ([]) (blocks, tops)
63 = do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
64 let allocs' = concat allocs
65 let ((BasicBlock id fstmts):rblocks) = blocks'
67 let fblocks = (BasicBlock id (fplog ++ allocs' ++ fstmts)):rblocks
68 return (env, fblocks, tops)
70 basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
71 = do (env', lb, lt) <- basicBlockCodeGen env block
72 let lblocks = lblocks' ++ lb
73 let ltops = ltops' ++ lt
74 basicBlocksCodeGen env' blocks (lblocks, ltops)
77 -- | Generate code for one block
78 basicBlockCodeGen :: LlvmEnv
80 -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmTop] )
81 basicBlockCodeGen env (BasicBlock id stmts)
82 = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
83 return (env', [BasicBlock id (fromOL instrs)], top)
86 -- | Allocations need to be extracted so they can be moved to the entry
87 -- of a function to make sure they dominate all possible paths in the CFG.
88 dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
89 dominateAllocs (BasicBlock id stmts)
90 = (BasicBlock id allstmts, allallocs)
92 (allstmts, allallocs) = foldl split ([],[]) stmts
93 split (stmts', allocs) s@(Assignment _ (Alloca _ _))
94 = (stmts', allocs ++ [s])
95 split (stmts', allocs) other
96 = (stmts' ++ [other], allocs)
99 -- -----------------------------------------------------------------------------
100 -- * CmmStmt code generation
103 -- A statement conversion return data.
104 -- * LlvmEnv: The new environment
105 -- * LlvmStatements: The compiled LLVM statements.
106 -- * LlvmCmmTop: Any global data needed.
107 type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmTop])
110 -- | Convert a list of CmmStmt's to LlvmStatement's
111 stmtsToInstrs :: LlvmEnv -> [CmmStmt] -> (LlvmStatements, [LlvmCmmTop])
113 stmtsToInstrs env [] (llvm, top)
114 = return (env, llvm, top)
116 stmtsToInstrs env (stmt : stmts) (llvm, top)
117 = do (env', instrs, tops) <- stmtToInstrs env stmt
118 stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops)
121 -- | Convert a CmmStmt to a list of LlvmStatement's
122 stmtToInstrs :: LlvmEnv -> CmmStmt
124 stmtToInstrs env stmt = case stmt of
126 CmmNop -> return (env, nilOL, [])
127 CmmComment _ -> return (env, nilOL, []) -- nuke comments
129 CmmAssign reg src -> genAssign env reg src
130 CmmStore addr src -> genStore env addr src
132 CmmBranch id -> genBranch env id
133 CmmCondBranch arg id -> genCondBranch env arg id
134 CmmSwitch arg ids -> genSwitch env arg ids
137 CmmCall target res args _ ret
138 -> genCall env target res args ret
141 CmmJump arg _ -> genJump env arg
143 -- CPS, only tail calls, no return's
144 -- Actually, there are a few return statements that occur because of hand
147 -> return (env, unitOL $ Return Nothing, [])
151 genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals
152 -> CmmReturnInfo -> UniqSM StmtData
154 -- Write barrier needs to be handled specially as it is implemented as an LLVM
155 -- intrinsic function.
156 genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
157 let fname = fsLit "llvm.memory.barrier"
158 let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
159 FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign
160 let fty = LMFunction funSig
162 let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False
163 let tops = case funLookup fname env of
165 Nothing -> [CmmData Data [([],[fty])]]
167 let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue]
168 let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs
169 let env' = funInsert fname fty env
171 return (env', unitOL s1, tops)
175 lmTrue = LMLitVar $ LMIntLit (-1) i1
177 -- Handle all other foreign calls and prim ops.
178 genCall env target res args ret = do
181 let arg_type (CmmHinted _ AddrHint) = i8Ptr
182 -- cast pointers to i8*. Llvm equivalent of void*
183 arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType expr
186 let ret_type ([]) = LMVoid
187 ret_type ([CmmHinted _ AddrHint]) = i8Ptr
188 ret_type ([CmmHinted reg _]) = cmmToLlvmType $ localRegType reg
189 ret_type t = panic $ "genCall: Too many return values! Can only handle"
190 ++ " 0 or 1, given " ++ show (length t) ++ "."
192 -- extract Cmm call convention
193 let cconv = case target of
194 CmmCallee _ conv -> conv
195 CmmPrim _ -> PrimCallConv
197 -- translate to LLVM call convention
198 let lmconv = case cconv of
199 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
200 StdCallConv -> CC_X86_Stdcc
202 StdCallConv -> CC_Ccc
205 PrimCallConv -> CC_Ccc
206 CmmCallConv -> panic "CmmCallConv not supported here!"
209 Some of the possibilities here are a worry with the use of a custom
210 calling convention for passing STG args. In practice the more
211 dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
213 The native code generator only handles StdCall and CCallConv.
217 let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs
218 | otherwise = llvmStdFunAttrs
221 let ccTy = StdCall -- tail calls should be done through CmmJump
222 let retTy = ret_type res
223 let argTy = tysToParams $ map arg_type args
224 let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible
225 lmconv retTy FixedArgs argTy llvmFunAlign
227 -- get parameter values
228 (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
230 -- get the return register
231 let ret_reg ([CmmHinted reg hint]) = (reg, hint)
232 ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
233 ++ " 1, given " ++ show (length t) ++ "."
235 -- deal with call types
236 let getFunPtr :: CmmCallTarget -> UniqSM ExprData
237 getFunPtr targ = case targ of
238 CmmCallee (CmmLit (CmmLabel lbl)) _ -> do
239 let name = strCLabel_llvm lbl
240 case funLookup name env1 of
241 Just ty'@(LMFunction sig) -> do
242 -- Function in module in right form
243 let fun = LMGlobalVar name ty' (funcLinkage sig)
244 Nothing Nothing False
245 return (env1, fun, nilOL, [])
248 -- label in module but not function pointer, convert
249 let fty@(LMFunction sig) = funTy name
250 let fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
251 Nothing Nothing False
252 (v1, s1) <- doExpr (pLift fty)
253 $ Cast LM_Bitcast fun (pLift fty)
254 return (env1, v1, unitOL s1, [])
257 -- label not in module, create external reference
258 let fty@(LMFunction sig) = funTy name
259 let fun = LMGlobalVar name fty (funcLinkage sig)
260 Nothing Nothing False
261 let top = CmmData Data [([],[fty])]
262 let env' = funInsert name fty env1
263 return (env', fun, nilOL, [top])
265 CmmCallee expr _ -> do
266 (env', v1, stmts, top) <- exprToVar env1 expr
267 let fty = funTy $ fsLit "dynamic"
268 let cast = case getVarType v1 of
269 ty | isPointer ty -> LM_Bitcast
270 ty | isInt ty -> LM_Inttoptr
272 ty -> panic $ "genCall: Expr is of bad type for function"
273 ++ " call! (" ++ show (ty) ++ ")"
275 (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
276 return (env', v2, stmts `snocOL` s1, top)
279 let name = cmmPrimOpFunctions mop
280 let lbl = mkForeignLabel name Nothing
281 ForeignLabelInExternalPackage IsFunction
282 getFunPtr $ CmmCallee (CmmLit (CmmLabel lbl)) CCallConv
284 (env2, fptr, stmts2, top2) <- getFunPtr target
286 let retStmt | ccTy == TailCall = unitOL $ Return Nothing
287 | ret == CmmNeverReturns = unitOL $ Unreachable
290 {- In LLVM we pass the STG registers around everywhere in function calls.
291 So this means LLVM considers them live across the entire function, when
292 in reality they usually aren't. For Caller save registers across C calls
293 the saving and restoring of them is done by the Cmm code generator,
294 using Cmm local vars. So to stop LLVM saving them as well (and saving
295 all of them since it thinks they're always live, we trash them just
296 before the call by assigning the 'undef' value to them. The ones we
297 need are restored from the Cmm local var and the ones we don't need
298 are fine to be trashed.
300 let trashStmts = concatOL $ map trashReg activeStgRegs
302 let reg = lmGlobalRegVar r
303 ty = (pLower . getVarType) reg
304 trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
305 in case callerSaves r of
309 let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts
311 -- make the actual call
314 let s1 = Expr $ Call ccTy fptr argVars fnAttrs
315 let allStmts = stmts `snocOL` s1 `appOL` retStmt
316 return (env2, allStmts, top1 ++ top2)
319 (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
320 let (creg, _) = ret_reg res
321 let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
322 let allStmts = stmts `snocOL` s1 `appOL` stmts3
323 if retTy == pLower (getVarType vreg)
325 let s2 = Store v1 vreg
326 return (env3, allStmts `snocOL` s2 `appOL` retStmt,
327 top1 ++ top2 ++ top3)
329 let ty = pLower $ getVarType vreg
331 vt | isPointer vt -> LM_Bitcast
332 | isInt vt -> LM_Ptrtoint
334 panic $ "genCall: CmmReg bad match for"
337 (v2, s2) <- doExpr ty $ Cast op v1 ty
338 let s3 = Store v2 vreg
339 return (env3, allStmts `snocOL` s2 `snocOL` s3
340 `appOL` retStmt, top1 ++ top2 ++ top3)
343 -- | Conversion of call arguments.
346 -> ([LlvmVar], LlvmStatements, [LlvmCmmTop])
347 -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmTop])
349 arg_vars env [] (vars, stmts, tops)
350 = return (env, vars, stmts, tops)
352 arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
353 = do (env', v1, stmts', top') <- exprToVar env e
354 let op = case getVarType v1 of
355 ty | isPointer ty -> LM_Bitcast
356 ty | isInt ty -> LM_Inttoptr
358 a -> panic $ "genCall: Can't cast llvmType to i8*! ("
361 (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
362 arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
365 arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
366 = do (env', v1, stmts', top') <- exprToVar env e
367 arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
369 -- | Decide what C function to use to implement a CallishMachOp
370 cmmPrimOpFunctions :: CallishMachOp -> FastString
371 cmmPrimOpFunctions mop
373 MO_F32_Exp -> fsLit "expf"
374 MO_F32_Log -> fsLit "logf"
375 MO_F32_Sqrt -> fsLit "llvm.sqrt.f32"
376 MO_F32_Pwr -> fsLit "llvm.pow.f32"
378 MO_F32_Sin -> fsLit "llvm.sin.f32"
379 MO_F32_Cos -> fsLit "llvm.cos.f32"
380 MO_F32_Tan -> fsLit "tanf"
382 MO_F32_Asin -> fsLit "asinf"
383 MO_F32_Acos -> fsLit "acosf"
384 MO_F32_Atan -> fsLit "atanf"
386 MO_F32_Sinh -> fsLit "sinhf"
387 MO_F32_Cosh -> fsLit "coshf"
388 MO_F32_Tanh -> fsLit "tanhf"
390 MO_F64_Exp -> fsLit "exp"
391 MO_F64_Log -> fsLit "log"
392 MO_F64_Sqrt -> fsLit "llvm.sqrt.f64"
393 MO_F64_Pwr -> fsLit "llvm.pow.f64"
395 MO_F64_Sin -> fsLit "llvm.sin.f64"
396 MO_F64_Cos -> fsLit "llvm.cos.f64"
397 MO_F64_Tan -> fsLit "tan"
399 MO_F64_Asin -> fsLit "asin"
400 MO_F64_Acos -> fsLit "acos"
401 MO_F64_Atan -> fsLit "atan"
403 MO_F64_Sinh -> fsLit "sinh"
404 MO_F64_Cosh -> fsLit "cosh"
405 MO_F64_Tanh -> fsLit "tanh"
407 a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")"
410 -- | Tail function calls
411 genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData
413 -- Call to known function
414 genJump env (CmmLit (CmmLabel lbl)) = do
415 (env', vf, stmts, top) <- getHsFunc env lbl
416 (stgRegs, stgStmts) <- funEpilogue
417 let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
418 let s2 = Return Nothing
419 return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
422 -- Call to unknown function / address
423 genJump env expr = do
425 (env', vf, stmts, top) <- exprToVar env expr
427 let cast = case getVarType vf of
428 ty | isPointer ty -> LM_Bitcast
429 ty | isInt ty -> LM_Inttoptr
431 ty -> panic $ "genJump: Expr is of bad type for function call! ("
434 (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
435 (stgRegs, stgStmts) <- funEpilogue
436 let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
437 let s3 = Return Nothing
438 return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
442 -- | CmmAssign operation
444 -- We use stack allocated variables for CmmReg. The optimiser will replace
445 -- these with registers when possible.
446 genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData
447 genAssign env reg val = do
448 let (env1, vreg, stmts1, top1) = getCmmReg env reg
449 (env2, vval, stmts2, top2) <- exprToVar env1 val
450 let stmts = stmts1 `appOL` stmts2
452 let ty = (pLower . getVarType) vreg
453 case isPointer ty && getVarType vval == llvmWord of
454 -- Some registers are pointer types, so need to cast value to pointer
456 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
457 let s2 = Store v vreg
458 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
461 let s1 = Store vval vreg
462 return (env2, stmts `snocOL` s1, top1 ++ top2)
465 -- | CmmStore operation
466 genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
468 -- First we try to detect a few common cases and produce better code for
469 -- these then the default case. We are mostly trying to detect Cmm code
470 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
471 -- generic case that uses casts and pointer arithmetic
472 genStore env addr@(CmmReg (CmmGlobal r)) val
473 = genStore_fast env addr r 0 val
475 genStore env addr@(CmmRegOff (CmmGlobal r) n) val
476 = genStore_fast env addr r n val
478 genStore env addr@(CmmMachOp (MO_Add _) [
479 (CmmReg (CmmGlobal r)),
480 (CmmLit (CmmInt n _))])
482 = genStore_fast env addr r (fromInteger n) val
484 genStore env addr@(CmmMachOp (MO_Sub _) [
485 (CmmReg (CmmGlobal r)),
486 (CmmLit (CmmInt n _))])
488 = genStore_fast env addr r (negate $ fromInteger n) val
491 genStore env addr val = genStore_slow env addr val
493 -- | CmmStore operation
494 -- This is a special case for storing to a global register pointer
495 -- offset such as I32[Sp+8].
496 genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr
498 genStore_fast env addr r n val
499 = let gr = lmGlobalRegVar r
500 grt = (pLower . getVarType) gr
501 (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
502 in case isPointer grt && rem == 0 of
504 (env', vval, stmts, top) <- exprToVar env val
505 (gv, s1) <- doExpr grt $ Load gr
506 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
507 -- We might need a different pointer type, so check
508 case pLower grt == getVarType vval of
511 let s3 = Store vval ptr
512 return (env', stmts `snocOL` s1 `snocOL` s2
515 -- cast to pointer type needed
517 let ty = (pLift . getVarType) vval
518 (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
519 let s4 = Store vval ptr'
520 return (env', stmts `snocOL` s1 `snocOL` s2
521 `snocOL` s3 `snocOL` s4, top)
523 -- If its a bit type then we use the slow method since
524 -- we can't avoid casting anyway.
525 False -> genStore_slow env addr val
528 -- | CmmStore operation
529 -- Generic case. Uses casts and pointer arithmetic if needed.
530 genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
531 genStore_slow env addr val = do
532 (env1, vaddr, stmts1, top1) <- exprToVar env addr
533 (env2, vval, stmts2, top2) <- exprToVar env1 val
535 let stmts = stmts1 `appOL` stmts2
536 case getVarType vaddr of
537 -- sometimes we need to cast an int to a pointer before storing
538 LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do
539 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
540 let s2 = Store v vaddr
541 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
544 let s1 = Store vval vaddr
545 return (env2, stmts `snocOL` s1, top1 ++ top2)
547 i@(LMInt _) | i == llvmWord -> do
548 let vty = pLift $ getVarType vval
549 (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
550 let s2 = Store vval vptr
551 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
554 pprPanic "genStore: ptr not right type!"
555 (PprCmm.pprExpr addr <+> text (
556 "Size of Ptr: " ++ show llvmPtrBits ++
557 ", Size of var: " ++ show (llvmWidthInBits other) ++
558 ", Var: " ++ show vaddr))
561 -- | Unconditional branch
562 genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData
564 let label = blockIdToLlvm id
565 in return (env, unitOL $ Branch label, [])
568 -- | Conditional branch
569 genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData
570 genCondBranch env cond idT = do
572 let labelT = blockIdToLlvm idT
573 let labelF = LMLocalVar idF LMLabel
574 (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
575 if getVarType vc == i1
577 let s1 = BranchIf vc labelT labelF
579 return $ (env', stmts `snocOL` s1 `snocOL` s2, top)
581 panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
586 -- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
587 -- However, they may be defined one day, so we better document this behaviour.
588 genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
589 genSwitch env cond maybe_ids = do
590 (env', vc, stmts, top) <- exprToVar env cond
591 let ty = getVarType vc
593 let pairs = [ (ix, id) | (ix,Just id) <- zip ([0..]::[Integer]) maybe_ids ]
594 let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
595 -- out of range is undefied, so lets just branch to first label
596 let (_, defLbl) = head labels
598 let s1 = Switch vc defLbl labels
599 return $ (env', stmts `snocOL` s1, top)
602 -- -----------------------------------------------------------------------------
603 -- * CmmExpr code generation
606 -- | An expression conversion return data:
607 -- * LlvmEnv: The new enviornment
608 -- * LlvmVar: The var holding the result of the expression
609 -- * LlvmStatements: Any statements needed to evaluate the expression
610 -- * LlvmCmmTop: Any global data needed for this expression
611 type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmTop])
613 -- | Values which can be passed to 'exprToVar' to configure its
614 -- behaviour in certain circumstances.
615 data EOption = EOption {
616 -- | The expected LlvmType for the returned variable.
618 -- Currently just used for determining if a comparison should return
619 -- a boolean (i1) or a int (i32/i64).
620 eoExpectedType :: Maybe LlvmType
624 i1Option = EOption (Just i1)
626 wordOption :: EOption
627 wordOption = EOption (Just llvmWord)
630 -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
631 -- expression being stored in the returned LlvmVar.
632 exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
633 exprToVar env = exprToVarOpt env wordOption
635 exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
636 exprToVarOpt env opt e = case e of
644 -- Cmmreg in expression is the value, so must load. If you want actual
645 -- reg pointer, call getCmmReg directly.
647 let (env', vreg, stmts, top) = getCmmReg env r
648 (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg
649 case (isPointer . getVarType) v1 of
651 -- Cmm wants the value, so pointer types must be cast to ints
652 (v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord
653 return (env', v2, stmts `snocOL` s1 `snocOL` s2, top)
655 False -> return (env', v1, stmts `snocOL` s1, top)
658 -> genMachOp env opt op exprs
661 -> exprToVar env $ expandCmmReg (r, i)
664 -> panic "exprToVar: CmmStackSlot not supported!"
667 -- | Handle CmmMachOp expressions
668 genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
671 genMachOp env _ op [x] = case op of
674 let all1 = mkIntLit (widthToLlvmInt w) (-1::Int)
675 in negate (widthToLlvmInt w) all1 LM_MO_Xor
678 let all0 = mkIntLit (widthToLlvmInt w) (0::Int)
679 in negate (widthToLlvmInt w) all0 LM_MO_Sub
682 let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
683 in negate (widthToLlvmFloat w) all0 LM_MO_FSub
685 MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
686 MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
689 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
692 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
695 -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
697 a -> panic $ "genMachOp: unmatched unary CmmMachOp! (" ++ show a ++ ")"
700 negate ty v2 negOp = do
701 (env', vx, stmts, top) <- exprToVar env x
702 (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
703 return (env', v1, stmts `snocOL` s1, top)
705 fiConv ty convOp = do
706 (env', vx, stmts, top) <- exprToVar env x
707 (v1, s1) <- doExpr ty $ Cast convOp vx ty
708 return (env', v1, stmts `snocOL` s1, top)
710 sameConv from ty reduce expand = do
711 x'@(env', vx, stmts, top) <- exprToVar env x
712 let sameConv' op = do
713 (v1, s1) <- doExpr ty $ Cast op vx ty
714 return (env', v1, stmts `snocOL` s1, top)
715 let toWidth = llvmWidthInBits ty
716 -- LLVM doesn't like trying to convert to same width, so
717 -- need to check for that as we do get Cmm code doing it.
718 case widthInBits from of
719 w | w < toWidth -> sameConv' expand
720 w | w > toWidth -> sameConv' reduce
723 -- Handle GlobalRegs pointers
724 genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
725 = genMachOp_fast env opt o r (fromInteger n) e
727 genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
728 = genMachOp_fast env opt o r (negate . fromInteger $ n) e
731 genMachOp env opt op e = genMachOp_slow env opt op e
734 -- | Handle CmmMachOp expressions
735 -- This is a specialised method that handles Global register manipulations like
736 -- 'Sp - 16', using the getelementptr instruction.
737 genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
739 genMachOp_fast env opt op r n e
740 = let gr = lmGlobalRegVar r
741 grt = (pLower . getVarType) gr
742 (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
743 in case isPointer grt && rem == 0 of
745 (gv, s1) <- doExpr grt $ Load gr
746 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
747 (var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord
748 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])
750 False -> genMachOp_slow env opt op e
753 -- | Handle CmmMachOp expressions
754 -- This handles all the cases not handle by the specialised genMachOp_fast.
755 genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
758 genMachOp_slow env opt op [x, y] = case op of
760 MO_Eq _ -> genBinComp opt LM_CMP_Eq
761 MO_Ne _ -> genBinComp opt LM_CMP_Ne
763 MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
764 MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
765 MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
766 MO_S_Le _ -> genBinComp opt LM_CMP_Sle
768 MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
769 MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
770 MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
771 MO_U_Le _ -> genBinComp opt LM_CMP_Ule
773 MO_Add _ -> genBinMach LM_MO_Add
774 MO_Sub _ -> genBinMach LM_MO_Sub
775 MO_Mul _ -> genBinMach LM_MO_Mul
777 MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
779 MO_S_MulMayOflo w -> isSMulOK w x y
781 MO_S_Quot _ -> genBinMach LM_MO_SDiv
782 MO_S_Rem _ -> genBinMach LM_MO_SRem
784 MO_U_Quot _ -> genBinMach LM_MO_UDiv
785 MO_U_Rem _ -> genBinMach LM_MO_URem
787 MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
788 MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
789 MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
790 MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
791 MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
792 MO_F_Le _ -> genBinComp opt LM_CMP_Fle
794 MO_F_Add _ -> genBinMach LM_MO_FAdd
795 MO_F_Sub _ -> genBinMach LM_MO_FSub
796 MO_F_Mul _ -> genBinMach LM_MO_FMul
797 MO_F_Quot _ -> genBinMach LM_MO_FDiv
799 MO_And _ -> genBinMach LM_MO_And
800 MO_Or _ -> genBinMach LM_MO_Or
801 MO_Xor _ -> genBinMach LM_MO_Xor
802 MO_Shl _ -> genBinMach LM_MO_Shl
803 MO_U_Shr _ -> genBinMach LM_MO_LShr
804 MO_S_Shr _ -> genBinMach LM_MO_AShr
806 a -> panic $ "genMachOp: unmatched binary CmmMachOp! (" ++ show a ++ ")"
809 binLlvmOp ty binOp = do
810 (env1, vx, stmts1, top1) <- exprToVar env x
811 (env2, vy, stmts2, top2) <- exprToVar env1 y
812 if getVarType vx == getVarType vy
814 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
815 return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1,
819 -- XXX: Error. Continue anyway so we can debug the generated
821 let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr)
822 let dx = Comment $ map fsLit $ cmmToStr x
823 let dy = Comment $ map fsLit $ cmmToStr y
824 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
825 let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
826 `snocOL` dy `snocOL` s1
827 return (env2, v1, allStmts, top1 ++ top2)
829 -- let o = case binOp vx vy of
830 -- Compare op _ _ -> show op
831 -- LlvmOp op _ _ -> show op
833 -- panic $ "genMachOp: comparison between different types ("
834 -- ++ o ++ " "++ show vx ++ ", " ++ show vy ++ ")"
835 -- ++ "\ne1: " ++ (show.llvmSDoc.PprCmm.pprExpr $ x)
836 -- ++ "\ne2: " ++ (show.llvmSDoc.PprCmm.pprExpr $ y)
838 -- | Need to use EOption here as Cmm expects word size results from
839 -- comparisons while LLVM return i1. Need to extend to llvmWord type
841 genBinComp opt cmp = do
842 ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) $ Compare cmp
844 if getVarType v1 == i1
846 case eoExpectedType opt of
854 (v2, s1) <- doExpr t $ Cast LM_Zext v1 t
855 return (env', v2, stmts `snocOL` s1, top)
858 panic $ "genBinComp: Can't case i1 compare"
859 ++ "res to non int type " ++ show (t)
861 panic $ "genBinComp: Compare returned type other then i1! "
862 ++ (show $ getVarType v1)
864 genBinMach op = binLlvmOp getVarType (LlvmOp op)
866 -- | Detect if overflow will occur in signed multiply of the two
867 -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
868 -- implementation. Its much longer due to type information/safety.
869 -- This should actually compile to only about 3 asm instructions.
870 isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData
872 (env1, vx, stmts1, top1) <- exprToVar env x
873 (env2, vy, stmts2, top2) <- exprToVar env1 y
875 let word = getVarType vx
876 let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx)
877 let shift = llvmWidthInBits word
878 let shift1 = toIWord (shift - 1)
879 let shift2 = toIWord shift
883 (x1, s1) <- doExpr word2 $ Cast LM_Sext vx word2
884 (y1, s2) <- doExpr word2 $ Cast LM_Sext vy word2
885 (r1, s3) <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
886 (rlow1, s4) <- doExpr word $ Cast LM_Trunc r1 word
887 (rlow2, s5) <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
888 (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
889 (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
890 (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
891 let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
892 `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
893 return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts,
897 panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"
899 -- More then two expression, invalid!
900 genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
903 -- | Handle CmmLoad expression.
904 genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
906 -- First we try to detect a few common cases and produce better code for
907 -- these then the default case. We are mostly trying to detect Cmm code
908 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
909 -- generic case that uses casts and pointer arithmetic
910 genLoad env e@(CmmReg (CmmGlobal r)) ty
911 = genLoad_fast env e r 0 ty
913 genLoad env e@(CmmRegOff (CmmGlobal r) n) ty
914 = genLoad_fast env e r n ty
916 genLoad env e@(CmmMachOp (MO_Add _) [
917 (CmmReg (CmmGlobal r)),
918 (CmmLit (CmmInt n _))])
920 = genLoad_fast env e r (fromInteger n) ty
922 genLoad env e@(CmmMachOp (MO_Sub _) [
923 (CmmReg (CmmGlobal r)),
924 (CmmLit (CmmInt n _))])
926 = genLoad_fast env e r (negate $ fromInteger n) ty
929 genLoad env e ty = genLoad_slow env e ty
931 -- | Handle CmmLoad expression.
932 -- This is a special case for loading from a global register pointer
933 -- offset such as I32[Sp+8].
934 genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
936 genLoad_fast env e r n ty =
937 let gr = lmGlobalRegVar r
938 grt = (pLower . getVarType) gr
939 ty' = cmmToLlvmType ty
940 (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
941 in case isPointer grt && rem == 0 of
943 (gv, s1) <- doExpr grt $ Load gr
944 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
945 -- We might need a different pointer type, so check
949 (var, s3) <- doExpr ty' $ Load ptr
950 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3,
953 -- cast to pointer type needed
956 (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
957 (var, s4) <- doExpr ty' $ Load ptr'
958 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3
961 -- If its a bit type then we use the slow method since
962 -- we can't avoid casting anyway.
963 False -> genLoad_slow env e ty
966 -- | Handle Cmm load expression.
967 -- Generic case. Uses casts and pointer arithmetic if needed.
968 genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
969 genLoad_slow env e ty = do
970 (env', iptr, stmts, tops) <- exprToVar env e
971 case getVarType iptr of
973 (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr
974 return (env', dvar, stmts `snocOL` load, tops)
976 i@(LMInt _) | i == llvmWord -> do
977 let pty = LMPointer $ cmmToLlvmType ty
978 (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty
979 (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr
980 return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
982 other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
983 (PprCmm.pprExpr e <+> text (
984 "Size of Ptr: " ++ show llvmPtrBits ++
985 ", Size of var: " ++ show (llvmWidthInBits other) ++
986 ", Var: " ++ show iptr))
989 -- | Handle CmmReg expression
991 -- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an
992 -- equivalent SSA form and avoids having to deal with Phi node insertion.
993 -- This is also the approach recommended by LLVM developers.
994 getCmmReg :: LlvmEnv -> CmmReg -> ExprData
995 getCmmReg env r@(CmmLocal (LocalReg un _))
996 = let exists = varLookup un env
998 (newv, stmts) = allocReg r
999 nenv = varInsert un (pLower $ getVarType newv) env
1001 Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, [])
1002 Nothing -> (nenv, newv, stmts, [])
1004 getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar g, nilOL, [])
1007 -- | Allocate a CmmReg on the stack
1008 allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
1009 allocReg (CmmLocal (LocalReg un ty))
1010 = let ty' = cmmToLlvmType ty
1011 var = LMLocalVar un (LMPointer ty')
1013 in (var, unitOL $ Assignment var alc)
1015 allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
1016 ++ " have been handled elsewhere!"
1019 -- | Generate code for a literal
1020 genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData
1021 genLit env (CmmInt i w)
1022 = return (env, mkIntLit (LMInt $ widthInBits w) i, nilOL, [])
1024 genLit env (CmmFloat r w)
1025 = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
1028 genLit env cmm@(CmmLabel l)
1029 = let label = strCLabel_llvm l
1030 ty = funLookup label env
1031 lmty = cmmToLlvmType $ cmmLitType cmm
1033 -- Make generic external label definition and then pointer to it
1035 let glob@(var, _) = genStringLabelRef label
1036 let ldata = [CmmData Data [([glob], [])]]
1037 let env' = funInsert label (pLower $ getVarType var) env
1038 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
1039 return (env', v1, unitOL s1, ldata)
1041 -- Referenced data exists in this module, retrieve type and make
1044 let var = LMGlobalVar label (LMPointer ty')
1045 ExternallyVisible Nothing Nothing False
1046 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
1047 return (env, v1, unitOL s1, [])
1049 genLit env (CmmLabelOff label off) = do
1050 (env', vlbl, stmts, stat) <- genLit env (CmmLabel label)
1051 let voff = toIWord off
1052 (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
1053 return (env', v1, stmts `snocOL` s1, stat)
1055 genLit env (CmmLabelDiffOff l1 l2 off) = do
1056 (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1)
1057 (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2)
1058 let voff = toIWord off
1059 let ty1 = getVarType vl1
1060 let ty2 = getVarType vl2
1061 if (isInt ty1) && (isInt ty2)
1062 && (llvmWidthInBits ty1 == llvmWidthInBits ty2)
1065 (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
1066 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
1067 return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
1071 panic "genLit: CmmLabelDiffOff encountered with different label ty!"
1073 genLit env (CmmBlock b)
1074 = genLit env (CmmLabel $ infoTblLbl b)
1076 genLit _ CmmHighStackMark
1077 = panic "genStaticLit - CmmHighStackMark unsupported!"
1080 -- -----------------------------------------------------------------------------
1084 -- | Function prologue. Load STG arguments into variables for function.
1085 funPrologue :: UniqSM [LlvmStatement]
1086 funPrologue = liftM concat $ mapM getReg activeStgRegs
1088 let reg = lmGlobalRegVar rr
1089 arg = lmGlobalRegArg rr
1090 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
1091 in return [alloc, Store arg reg]
1094 -- | Function epilogue. Load STG variables to use as argument for call.
1095 funEpilogue :: UniqSM ([LlvmVar], LlvmStatements)
1098 let reg = lmGlobalRegVar r
1099 (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
1100 return (v, unitOL s)
1101 loads <- mapM loadExpr activeStgRegs
1102 let (vars, stmts) = unzip loads
1103 return (vars, concatOL stmts)
1106 -- | Get a function pointer to the CLabel specified.
1108 -- This is for Haskell functions, function type is assumed, so doesn't work
1109 -- with foreign functions.
1110 getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData
1112 = let fn = strCLabel_llvm lbl
1113 ty = funLookup fn env
1115 -- Function in module in right form
1116 Just ty'@(LMFunction sig) -> do
1117 let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False
1118 return (env, fun, nilOL, [])
1120 -- label in module but not function pointer, convert
1122 let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
1123 Nothing Nothing False
1124 (v1, s1) <- doExpr (pLift llvmFunTy) $
1125 Cast LM_Bitcast fun (pLift llvmFunTy)
1126 return (env, v1, unitOL s1, [])
1128 -- label not in module, create external reference
1130 let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible
1131 let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
1132 let top = CmmData Data [([],[ty'])]
1133 let env' = funInsert fn ty' env
1134 return (env', fun, nilOL, [top])
1137 -- | Create a new local var
1138 mkLocalVar :: LlvmType -> UniqSM LlvmVar
1141 return $ LMLocalVar un ty
1144 -- | Execute an expression, assigning result to a var
1145 doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement)
1148 return (v, Assignment v expr)
1151 -- | Expand CmmRegOff
1152 expandCmmReg :: (CmmReg, Int) -> CmmExpr
1153 expandCmmReg (reg, off)
1154 = let width = typeWidth (cmmRegType reg)
1155 voff = CmmLit $ CmmInt (fromIntegral off) width
1156 in CmmMachOp (MO_Add width) [CmmReg reg, voff]
1159 -- | Convert a block id into a appropriate Llvm label
1160 blockIdToLlvm :: BlockId -> LlvmVar
1161 blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
1163 -- | Create Llvm int Literal
1164 mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
1165 mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
1167 -- | Convert int type to a LLvmVar of word or i32 size
1168 toI32, toIWord :: Integral a => a -> LlvmVar
1169 toI32 = mkIntLit i32
1170 toIWord = mkIntLit llvmWord
1173 -- | Error functions
1174 panic :: String -> a
1175 panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
1177 pprPanic :: String -> SDoc -> a
1178 pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d