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 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 params (ListGraph blocks))
47 (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
49 let proc = CmmProc info lbl params (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 genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
156 let fname = fsLit "llvm.memory.barrier"
157 let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
158 FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign
159 let fty = LMFunction funSig
161 let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False
162 let tops = case funLookup fname env of
164 Nothing -> [CmmData Data [([],[fty])]]
166 let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue]
167 let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs
168 let env' = funInsert fname fty env
170 return (env', unitOL s1, tops)
174 lmTrue = LMLitVar $ LMIntLit (-1) i1
176 -- Handle all other foreign calls and prim ops.
177 genCall env target res args ret = do
180 let arg_type (CmmHinted _ AddrHint) = i8Ptr
181 -- cast pointers to i8*. Llvm equivalent of void*
182 arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType expr
185 let ret_type ([]) = LMVoid
186 ret_type ([CmmHinted _ AddrHint]) = i8Ptr
187 ret_type ([CmmHinted reg _]) = cmmToLlvmType $ localRegType reg
188 ret_type t = panic $ "genCall: Too many return values! Can only handle"
189 ++ " 0 or 1, given " ++ show (length t) ++ "."
191 -- extract Cmm call convention
192 let cconv = case target of
193 CmmCallee _ conv -> conv
194 CmmPrim _ -> PrimCallConv
196 -- translate to LLVM call convention
197 let lmconv = case cconv of
198 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
199 StdCallConv -> CC_X86_Stdcc
201 StdCallConv -> CC_Ccc
204 PrimCallConv -> CC_Ccc
205 CmmCallConv -> panic "CmmCallConv not supported here!"
208 Some of the possibilities here are a worry with the use of a custom
209 calling convention for passing STG args. In practice the more
210 dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
212 The native code generator only handles StdCall and CCallConv.
216 let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs
217 | otherwise = llvmStdFunAttrs
220 let ccTy = StdCall -- tail calls should be done through CmmJump
221 let retTy = ret_type res
222 let argTy = tysToParams $ map arg_type args
223 let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible
224 lmconv retTy FixedArgs argTy llvmFunAlign
226 -- get parameter values
227 (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
229 -- get the return register
230 let ret_reg ([CmmHinted reg hint]) = (reg, hint)
231 ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
232 ++ " 1, given " ++ show (length t) ++ "."
234 -- deal with call types
235 let getFunPtr :: CmmCallTarget -> UniqSM ExprData
236 getFunPtr targ = case targ of
237 CmmCallee (CmmLit (CmmLabel lbl)) _ -> do
238 let name = strCLabel_llvm lbl
239 case funLookup name env1 of
240 Just ty'@(LMFunction sig) -> do
241 -- Function in module in right form
242 let fun = LMGlobalVar name ty' (funcLinkage sig)
243 Nothing Nothing False
244 return (env1, fun, nilOL, [])
247 -- label in module but not function pointer, convert
248 let fty@(LMFunction sig) = funTy name
249 let fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
250 Nothing Nothing False
251 (v1, s1) <- doExpr (pLift fty)
252 $ Cast LM_Bitcast fun (pLift fty)
253 return (env1, v1, unitOL s1, [])
256 -- label not in module, create external reference
257 let fty@(LMFunction sig) = funTy name
258 let fun = LMGlobalVar name fty (funcLinkage sig)
259 Nothing Nothing False
260 let top = CmmData Data [([],[fty])]
261 let env' = funInsert name fty env1
262 return (env', fun, nilOL, [top])
264 CmmCallee expr _ -> do
265 (env', v1, stmts, top) <- exprToVar env1 expr
266 let fty = funTy $ fsLit "dynamic"
267 let cast = case getVarType v1 of
268 ty | isPointer ty -> LM_Bitcast
269 ty | isInt ty -> LM_Inttoptr
271 ty -> panic $ "genCall: Expr is of bad type for function"
272 ++ " call! (" ++ show (ty) ++ ")"
274 (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
275 return (env', v2, stmts `snocOL` s1, top)
278 let name = cmmPrimOpFunctions mop
279 let lbl = mkForeignLabel name Nothing
280 ForeignLabelInExternalPackage IsFunction
281 getFunPtr $ CmmCallee (CmmLit (CmmLabel lbl)) CCallConv
283 (env2, fptr, stmts2, top2) <- getFunPtr target
285 let retStmt | ccTy == TailCall = unitOL $ Return Nothing
286 | ret == CmmNeverReturns = unitOL $ Unreachable
289 {- In LLVM we pass the STG registers around everywhere in function calls.
290 So this means LLVM considers them live across the entire function, when
291 in reality they usually aren't. For Caller save registers across C calls
292 the saving and restoring of them is done by the Cmm code generator,
293 using Cmm local vars. So to stop LLVM saving them as well (and saving
294 all of them since it thinks they're always live, we trash them just
295 before the call by assigning the 'undef' value to them. The ones we
296 need are restored from the Cmm local var and the ones we don't need
297 are fine to be trashed.
299 let trashStmts = concatOL $ map trashReg activeStgRegs
301 let reg = lmGlobalRegVar r
302 ty = (pLower . getVarType) reg
303 trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
304 in case callerSaves r of
308 let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts
310 -- make the actual call
313 let s1 = Expr $ Call ccTy fptr argVars fnAttrs
314 let allStmts = stmts `snocOL` s1 `appOL` retStmt
315 return (env2, allStmts, top1 ++ top2)
318 (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
319 let (creg, _) = ret_reg res
320 let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
321 let allStmts = stmts `snocOL` s1 `appOL` stmts3
322 if retTy == pLower (getVarType vreg)
324 let s2 = Store v1 vreg
325 return (env3, allStmts `snocOL` s2 `appOL` retStmt,
326 top1 ++ top2 ++ top3)
328 let ty = pLower $ getVarType vreg
330 vt | isPointer vt -> LM_Bitcast
331 | isInt vt -> LM_Ptrtoint
333 panic $ "genCall: CmmReg bad match for"
336 (v2, s2) <- doExpr ty $ Cast op v1 ty
337 let s3 = Store v2 vreg
338 return (env3, allStmts `snocOL` s2 `snocOL` s3
339 `appOL` retStmt, top1 ++ top2 ++ top3)
342 -- | Conversion of call arguments.
345 -> ([LlvmVar], LlvmStatements, [LlvmCmmTop])
346 -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmTop])
348 arg_vars env [] (vars, stmts, tops)
349 = return (env, vars, stmts, tops)
351 arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
352 = do (env', v1, stmts', top') <- exprToVar env e
353 let op = case getVarType v1 of
354 ty | isPointer ty -> LM_Bitcast
355 ty | isInt ty -> LM_Inttoptr
357 a -> panic $ "genCall: Can't cast llvmType to i8*! ("
360 (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
361 arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
364 arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
365 = do (env', v1, stmts', top') <- exprToVar env e
366 arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
368 -- | Decide what C function to use to implement a CallishMachOp
369 cmmPrimOpFunctions :: CallishMachOp -> FastString
370 cmmPrimOpFunctions mop
372 MO_F32_Exp -> fsLit "expf"
373 MO_F32_Log -> fsLit "logf"
374 MO_F32_Sqrt -> fsLit "llvm.sqrt.f32"
375 MO_F32_Pwr -> fsLit "llvm.pow.f32"
377 MO_F32_Sin -> fsLit "llvm.sin.f32"
378 MO_F32_Cos -> fsLit "llvm.cos.f32"
379 MO_F32_Tan -> fsLit "tanf"
381 MO_F32_Asin -> fsLit "asinf"
382 MO_F32_Acos -> fsLit "acosf"
383 MO_F32_Atan -> fsLit "atanf"
385 MO_F32_Sinh -> fsLit "sinhf"
386 MO_F32_Cosh -> fsLit "coshf"
387 MO_F32_Tanh -> fsLit "tanhf"
389 MO_F64_Exp -> fsLit "exp"
390 MO_F64_Log -> fsLit "log"
391 MO_F64_Sqrt -> fsLit "llvm.sqrt.f64"
392 MO_F64_Pwr -> fsLit "llvm.pow.f64"
394 MO_F64_Sin -> fsLit "llvm.sin.f64"
395 MO_F64_Cos -> fsLit "llvm.cos.f64"
396 MO_F64_Tan -> fsLit "tan"
398 MO_F64_Asin -> fsLit "asin"
399 MO_F64_Acos -> fsLit "acos"
400 MO_F64_Atan -> fsLit "atan"
402 MO_F64_Sinh -> fsLit "sinh"
403 MO_F64_Cosh -> fsLit "cosh"
404 MO_F64_Tanh -> fsLit "tanh"
406 a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")"
409 -- | Tail function calls
410 genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData
412 -- Call to known function
413 genJump env (CmmLit (CmmLabel lbl)) = do
414 (env', vf, stmts, top) <- getHsFunc env lbl
415 (stgRegs, stgStmts) <- funEpilogue
416 let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
417 let s2 = Return Nothing
418 return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
421 -- Call to unknown function / address
422 genJump env expr = do
424 (env', vf, stmts, top) <- exprToVar env expr
426 let cast = case getVarType vf of
427 ty | isPointer ty -> LM_Bitcast
428 ty | isInt ty -> LM_Inttoptr
430 ty -> panic $ "genJump: Expr is of bad type for function call! ("
433 (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
434 (stgRegs, stgStmts) <- funEpilogue
435 let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
436 let s3 = Return Nothing
437 return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
441 -- | CmmAssign operation
443 -- We use stack allocated variables for CmmReg. The optimiser will replace
444 -- these with registers when possible.
445 genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData
446 genAssign env reg val = do
447 let (env1, vreg, stmts1, top1) = getCmmReg env reg
448 (env2, vval, stmts2, top2) <- exprToVar env1 val
449 let stmts = stmts1 `appOL` stmts2
451 let ty = (pLower . getVarType) vreg
452 case isPointer ty && getVarType vval == llvmWord of
453 -- Some registers are pointer types, so need to cast value to pointer
455 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
456 let s2 = Store v vreg
457 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
460 let s1 = Store vval vreg
461 return (env2, stmts `snocOL` s1, top1 ++ top2)
464 -- | CmmStore operation
465 genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
467 -- First we try to detect a few common cases and produce better code for
468 -- these then the default case. We are mostly trying to detect Cmm code
469 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
470 -- generic case that uses casts and pointer arithmetic
471 genStore env addr@(CmmReg (CmmGlobal r)) val
472 = genStore_fast env addr r 0 val
474 genStore env addr@(CmmRegOff (CmmGlobal r) n) val
475 = genStore_fast env addr r n val
477 genStore env addr@(CmmMachOp (MO_Add _) [
478 (CmmReg (CmmGlobal r)),
479 (CmmLit (CmmInt n _))])
481 = genStore_fast env addr r (fromInteger n) val
483 genStore env addr@(CmmMachOp (MO_Sub _) [
484 (CmmReg (CmmGlobal r)),
485 (CmmLit (CmmInt n _))])
487 = genStore_fast env addr r (negate $ fromInteger n) val
490 genStore env addr val = genStore_slow env addr val
492 -- | CmmStore operation
493 -- This is a special case for storing to a global register pointer
494 -- offset such as I32[Sp+8].
495 genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr
497 genStore_fast env addr r n val
498 = let gr = lmGlobalRegVar r
499 grt = (pLower . getVarType) gr
500 (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
501 in case isPointer grt && rem == 0 of
503 (env', vval, stmts, top) <- exprToVar env val
504 (gv, s1) <- doExpr grt $ Load gr
505 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
506 -- We might need a different pointer type, so check
507 case pLower grt == getVarType vval of
510 let s3 = Store vval ptr
511 return (env', stmts `snocOL` s1 `snocOL` s2
514 -- cast to pointer type needed
516 let ty = (pLift . getVarType) vval
517 (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
518 let s4 = Store vval ptr'
519 return (env', stmts `snocOL` s1 `snocOL` s2
520 `snocOL` s3 `snocOL` s4, top)
522 -- If its a bit type then we use the slow method since
523 -- we can't avoid casting anyway.
524 False -> genStore_slow env addr val
527 -- | CmmStore operation
528 -- Generic case. Uses casts and pointer arithmetic if needed.
529 genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
530 genStore_slow env addr val = do
531 (env1, vaddr, stmts1, top1) <- exprToVar env addr
532 (env2, vval, stmts2, top2) <- exprToVar env1 val
534 let stmts = stmts1 `appOL` stmts2
535 case getVarType vaddr of
536 -- sometimes we need to cast an int to a pointer before storing
537 LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do
538 (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
539 let s2 = Store v vaddr
540 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
543 let s1 = Store vval vaddr
544 return (env2, stmts `snocOL` s1, top1 ++ top2)
546 i@(LMInt _) | i == llvmWord -> do
547 let vty = pLift $ getVarType vval
548 (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
549 let s2 = Store vval vptr
550 return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
553 pprPanic "genStore: ptr not right type!"
554 (PprCmm.pprExpr addr <+> text (
555 "Size of Ptr: " ++ show llvmPtrBits ++
556 ", Size of var: " ++ show (llvmWidthInBits other) ++
557 ", Var: " ++ show vaddr))
560 -- | Unconditional branch
561 genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData
563 let label = blockIdToLlvm id
564 in return (env, unitOL $ Branch label, [])
567 -- | Conditional branch
568 genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData
569 genCondBranch env cond idT = do
571 let labelT = blockIdToLlvm idT
572 let labelF = LMLocalVar idF LMLabel
573 (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
574 if getVarType vc == i1
576 let s1 = BranchIf vc labelT labelF
578 return $ (env', stmts `snocOL` s1 `snocOL` s2, top)
580 panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
585 -- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
586 -- However, they may be defined one day, so we better document this behaviour.
587 genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
588 genSwitch env cond maybe_ids = do
589 (env', vc, stmts, top) <- exprToVar env cond
590 let ty = getVarType vc
592 let pairs = [ (ix, id) | (ix,Just id) <- zip ([0..]::[Integer]) maybe_ids ]
593 let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
594 -- out of range is undefied, so lets just branch to first label
595 let (_, defLbl) = head labels
597 let s1 = Switch vc defLbl labels
598 return $ (env', stmts `snocOL` s1, top)
601 -- -----------------------------------------------------------------------------
602 -- * CmmExpr code generation
605 -- | An expression conversion return data:
606 -- * LlvmEnv: The new enviornment
607 -- * LlvmVar: The var holding the result of the expression
608 -- * LlvmStatements: Any statements needed to evaluate the expression
609 -- * LlvmCmmTop: Any global data needed for this expression
610 type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmTop])
612 -- | Values which can be passed to 'exprToVar' to configure its
613 -- behaviour in certain circumstances.
614 data EOption = EOption {
615 -- | The expected LlvmType for the returned variable.
617 -- Currently just used for determining if a comparison should return
618 -- a boolean (i1) or a int (i32/i64).
619 eoExpectedType :: Maybe LlvmType
623 i1Option = EOption (Just i1)
625 wordOption :: EOption
626 wordOption = EOption (Just llvmWord)
629 -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
630 -- expression being stored in the returned LlvmVar.
631 exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
632 exprToVar env = exprToVarOpt env wordOption
634 exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
635 exprToVarOpt env opt e = case e of
643 -- Cmmreg in expression is the value, so must load. If you want actual
644 -- reg pointer, call getCmmReg directly.
646 let (env', vreg, stmts, top) = getCmmReg env r
647 (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg
648 case (isPointer . getVarType) v1 of
650 -- Cmm wants the value, so pointer types must be cast to ints
651 (v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord
652 return (env', v2, stmts `snocOL` s1 `snocOL` s2, top)
654 False -> return (env', v1, stmts `snocOL` s1, top)
657 -> genMachOp env opt op exprs
660 -> exprToVar env $ expandCmmReg (r, i)
663 -> panic "exprToVar: CmmStackSlot not supported!"
666 -- | Handle CmmMachOp expressions
667 genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
670 genMachOp env _ op [x] = case op of
673 let all1 = mkIntLit (widthToLlvmInt w) (-1::Int)
674 in negate (widthToLlvmInt w) all1 LM_MO_Xor
677 let all0 = mkIntLit (widthToLlvmInt w) (0::Int)
678 in negate (widthToLlvmInt w) all0 LM_MO_Sub
681 let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
682 in negate (widthToLlvmFloat w) all0 LM_MO_FSub
684 MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
685 MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
688 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
691 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
694 -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
696 a -> panic $ "genMachOp: unmatched unary CmmMachOp! (" ++ show a ++ ")"
699 negate ty v2 negOp = do
700 (env', vx, stmts, top) <- exprToVar env x
701 (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
702 return (env', v1, stmts `snocOL` s1, top)
704 fiConv ty convOp = do
705 (env', vx, stmts, top) <- exprToVar env x
706 (v1, s1) <- doExpr ty $ Cast convOp vx ty
707 return (env', v1, stmts `snocOL` s1, top)
709 sameConv from ty reduce expand = do
710 x'@(env', vx, stmts, top) <- exprToVar env x
711 let sameConv' op = do
712 (v1, s1) <- doExpr ty $ Cast op vx ty
713 return (env', v1, stmts `snocOL` s1, top)
714 let toWidth = llvmWidthInBits ty
715 -- LLVM doesn't like trying to convert to same width, so
716 -- need to check for that as we do get Cmm code doing it.
717 case widthInBits from of
718 w | w < toWidth -> sameConv' expand
719 w | w > toWidth -> sameConv' reduce
722 -- Handle GlobalRegs pointers
723 genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
724 = genMachOp_fast env opt o r (fromInteger n) e
726 genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
727 = genMachOp_fast env opt o r (negate . fromInteger $ n) e
730 genMachOp env opt op e = genMachOp_slow env opt op e
733 -- | Handle CmmMachOp expressions
734 -- This is a specialised method that handles Global register manipulations like
735 -- 'Sp - 16', using the getelementptr instruction.
736 genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
738 genMachOp_fast env opt op r n e
739 = let gr = lmGlobalRegVar r
740 grt = (pLower . getVarType) gr
741 (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
742 in case isPointer grt && rem == 0 of
744 (gv, s1) <- doExpr grt $ Load gr
745 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
746 (var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord
747 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])
749 False -> genMachOp_slow env opt op e
752 -- | Handle CmmMachOp expressions
753 -- This handles all the cases not handle by the specialised genMachOp_fast.
754 genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
757 genMachOp_slow env opt op [x, y] = case op of
759 MO_Eq _ -> genBinComp opt LM_CMP_Eq
760 MO_Ne _ -> genBinComp opt LM_CMP_Ne
762 MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
763 MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
764 MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
765 MO_S_Le _ -> genBinComp opt LM_CMP_Sle
767 MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
768 MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
769 MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
770 MO_U_Le _ -> genBinComp opt LM_CMP_Ule
772 MO_Add _ -> genBinMach LM_MO_Add
773 MO_Sub _ -> genBinMach LM_MO_Sub
774 MO_Mul _ -> genBinMach LM_MO_Mul
776 MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
778 MO_S_MulMayOflo w -> isSMulOK w x y
780 MO_S_Quot _ -> genBinMach LM_MO_SDiv
781 MO_S_Rem _ -> genBinMach LM_MO_SRem
783 MO_U_Quot _ -> genBinMach LM_MO_UDiv
784 MO_U_Rem _ -> genBinMach LM_MO_URem
786 MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
787 MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
788 MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
789 MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
790 MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
791 MO_F_Le _ -> genBinComp opt LM_CMP_Fle
793 MO_F_Add _ -> genBinMach LM_MO_FAdd
794 MO_F_Sub _ -> genBinMach LM_MO_FSub
795 MO_F_Mul _ -> genBinMach LM_MO_FMul
796 MO_F_Quot _ -> genBinMach LM_MO_FDiv
798 MO_And _ -> genBinMach LM_MO_And
799 MO_Or _ -> genBinMach LM_MO_Or
800 MO_Xor _ -> genBinMach LM_MO_Xor
801 MO_Shl _ -> genBinMach LM_MO_Shl
802 MO_U_Shr _ -> genBinMach LM_MO_LShr
803 MO_S_Shr _ -> genBinMach LM_MO_AShr
805 a -> panic $ "genMachOp: unmatched binary CmmMachOp! (" ++ show a ++ ")"
808 binLlvmOp ty binOp = do
809 (env1, vx, stmts1, top1) <- exprToVar env x
810 (env2, vy, stmts2, top2) <- exprToVar env1 y
811 if getVarType vx == getVarType vy
813 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
814 return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1,
818 -- XXX: Error. Continue anyway so we can debug the generated
820 let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr)
821 let dx = Comment $ map fsLit $ cmmToStr x
822 let dy = Comment $ map fsLit $ cmmToStr y
823 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
824 let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
825 `snocOL` dy `snocOL` s1
826 return (env2, v1, allStmts, top1 ++ top2)
828 -- let o = case binOp vx vy of
829 -- Compare op _ _ -> show op
830 -- LlvmOp op _ _ -> show op
832 -- panic $ "genMachOp: comparison between different types ("
833 -- ++ o ++ " "++ show vx ++ ", " ++ show vy ++ ")"
834 -- ++ "\ne1: " ++ (show.llvmSDoc.PprCmm.pprExpr $ x)
835 -- ++ "\ne2: " ++ (show.llvmSDoc.PprCmm.pprExpr $ y)
837 -- | Need to use EOption here as Cmm expects word size results from
838 -- comparisons while LLVM return i1. Need to extend to llvmWord type
840 genBinComp opt cmp = do
841 ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) $ Compare cmp
843 if getVarType v1 == i1
845 case eoExpectedType opt of
853 (v2, s1) <- doExpr t $ Cast LM_Zext v1 t
854 return (env', v2, stmts `snocOL` s1, top)
857 panic $ "genBinComp: Can't case i1 compare"
858 ++ "res to non int type " ++ show (t)
860 panic $ "genBinComp: Compare returned type other then i1! "
861 ++ (show $ getVarType v1)
863 genBinMach op = binLlvmOp getVarType (LlvmOp op)
865 -- | Detect if overflow will occur in signed multiply of the two
866 -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
867 -- implementation. Its much longer due to type information/safety.
868 -- This should actually compile to only about 3 asm instructions.
869 isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData
871 (env1, vx, stmts1, top1) <- exprToVar env x
872 (env2, vy, stmts2, top2) <- exprToVar env1 y
874 let word = getVarType vx
875 let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx)
876 let shift = llvmWidthInBits word
877 let shift1 = toIWord (shift - 1)
878 let shift2 = toIWord shift
882 (x1, s1) <- doExpr word2 $ Cast LM_Sext vx word2
883 (y1, s2) <- doExpr word2 $ Cast LM_Sext vy word2
884 (r1, s3) <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
885 (rlow1, s4) <- doExpr word $ Cast LM_Trunc r1 word
886 (rlow2, s5) <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
887 (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
888 (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
889 (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
890 let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
891 `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
892 return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts,
896 panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"
898 -- More then two expression, invalid!
899 genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
902 -- | Handle CmmLoad expression.
903 genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
905 -- First we try to detect a few common cases and produce better code for
906 -- these then the default case. We are mostly trying to detect Cmm code
907 -- like I32[Sp + n] and use 'getelementptr' operations instead of the
908 -- generic case that uses casts and pointer arithmetic
909 genLoad env e@(CmmReg (CmmGlobal r)) ty
910 = genLoad_fast env e r 0 ty
912 genLoad env e@(CmmRegOff (CmmGlobal r) n) ty
913 = genLoad_fast env e r n ty
915 genLoad env e@(CmmMachOp (MO_Add _) [
916 (CmmReg (CmmGlobal r)),
917 (CmmLit (CmmInt n _))])
919 = genLoad_fast env e r (fromInteger n) ty
921 genLoad env e@(CmmMachOp (MO_Sub _) [
922 (CmmReg (CmmGlobal r)),
923 (CmmLit (CmmInt n _))])
925 = genLoad_fast env e r (negate $ fromInteger n) ty
928 genLoad env e ty = genLoad_slow env e ty
930 -- | Handle CmmLoad expression.
931 -- This is a special case for loading from a global register pointer
932 -- offset such as I32[Sp+8].
933 genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
935 genLoad_fast env e r n ty =
936 let gr = lmGlobalRegVar r
937 grt = (pLower . getVarType) gr
938 ty' = cmmToLlvmType ty
939 (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
940 in case isPointer grt && rem == 0 of
942 (gv, s1) <- doExpr grt $ Load gr
943 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
944 -- We might need a different pointer type, so check
948 (var, s3) <- doExpr ty' $ Load ptr
949 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3,
952 -- cast to pointer type needed
955 (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
956 (var, s4) <- doExpr ty' $ Load ptr'
957 return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3
960 -- If its a bit type then we use the slow method since
961 -- we can't avoid casting anyway.
962 False -> genLoad_slow env e ty
965 -- | Handle Cmm load expression.
966 -- Generic case. Uses casts and pointer arithmetic if needed.
967 genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
968 genLoad_slow env e ty = do
969 (env', iptr, stmts, tops) <- exprToVar env e
970 case getVarType iptr of
972 (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr
973 return (env', dvar, stmts `snocOL` load, tops)
975 i@(LMInt _) | i == llvmWord -> do
976 let pty = LMPointer $ cmmToLlvmType ty
977 (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty
978 (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr
979 return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
981 other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
982 (PprCmm.pprExpr e <+> text (
983 "Size of Ptr: " ++ show llvmPtrBits ++
984 ", Size of var: " ++ show (llvmWidthInBits other) ++
985 ", Var: " ++ show iptr))
988 -- | Handle CmmReg expression
990 -- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an
991 -- equivalent SSA form and avoids having to deal with Phi node insertion.
992 -- This is also the approach recommended by LLVM developers.
993 getCmmReg :: LlvmEnv -> CmmReg -> ExprData
994 getCmmReg env r@(CmmLocal (LocalReg un _))
995 = let exists = varLookup un env
997 (newv, stmts) = allocReg r
998 nenv = varInsert un (pLower $ getVarType newv) env
1000 Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, [])
1001 Nothing -> (nenv, newv, stmts, [])
1003 getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar g, nilOL, [])
1006 -- | Allocate a CmmReg on the stack
1007 allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
1008 allocReg (CmmLocal (LocalReg un ty))
1009 = let ty' = cmmToLlvmType ty
1010 var = LMLocalVar un (LMPointer ty')
1012 in (var, unitOL $ Assignment var alc)
1014 allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
1015 ++ " have been handled elsewhere!"
1018 -- | Generate code for a literal
1019 genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData
1020 genLit env (CmmInt i w)
1021 = return (env, mkIntLit (LMInt $ widthInBits w) i, nilOL, [])
1023 genLit env (CmmFloat r w)
1024 = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
1027 genLit env cmm@(CmmLabel l)
1028 = let label = strCLabel_llvm l
1029 ty = funLookup label env
1030 lmty = cmmToLlvmType $ cmmLitType cmm
1032 -- Make generic external label definition and then pointer to it
1034 let glob@(var, _) = genStringLabelRef label
1035 let ldata = [CmmData Data [([glob], [])]]
1036 let env' = funInsert label (pLower $ getVarType var) env
1037 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
1038 return (env', v1, unitOL s1, ldata)
1040 -- Referenced data exists in this module, retrieve type and make
1043 let var = LMGlobalVar label (LMPointer ty')
1044 ExternallyVisible Nothing Nothing False
1045 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
1046 return (env, v1, unitOL s1, [])
1048 genLit env (CmmLabelOff label off) = do
1049 (env', vlbl, stmts, stat) <- genLit env (CmmLabel label)
1050 let voff = toIWord off
1051 (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
1052 return (env', v1, stmts `snocOL` s1, stat)
1054 genLit env (CmmLabelDiffOff l1 l2 off) = do
1055 (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1)
1056 (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2)
1057 let voff = toIWord off
1058 let ty1 = getVarType vl1
1059 let ty2 = getVarType vl2
1060 if (isInt ty1) && (isInt ty2)
1061 && (llvmWidthInBits ty1 == llvmWidthInBits ty2)
1064 (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
1065 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
1066 return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
1070 panic "genLit: CmmLabelDiffOff encountered with different label ty!"
1072 genLit env (CmmBlock b)
1073 = genLit env (CmmLabel $ infoTblLbl b)
1075 genLit _ CmmHighStackMark
1076 = panic "genStaticLit - CmmHighStackMark unsupported!"
1079 -- -----------------------------------------------------------------------------
1083 -- | Function prologue. Load STG arguments into variables for function.
1084 funPrologue :: UniqSM [LlvmStatement]
1085 funPrologue = liftM concat $ mapM getReg activeStgRegs
1087 let reg = lmGlobalRegVar rr
1088 arg = lmGlobalRegArg rr
1089 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
1090 in return [alloc, Store arg reg]
1093 -- | Function epilogue. Load STG variables to use as argument for call.
1094 funEpilogue :: UniqSM ([LlvmVar], LlvmStatements)
1097 let reg = lmGlobalRegVar r
1098 (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
1099 return (v, unitOL s)
1100 loads <- mapM loadExpr activeStgRegs
1101 let (vars, stmts) = unzip loads
1102 return (vars, concatOL stmts)
1105 -- | Get a function pointer to the CLabel specified.
1107 -- This is for Haskell functions, function type is assumed, so doesn't work
1108 -- with foreign functions.
1109 getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData
1111 = let fn = strCLabel_llvm lbl
1112 ty = funLookup fn env
1114 -- Function in module in right form
1115 Just ty'@(LMFunction sig) -> do
1116 let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False
1117 return (env, fun, nilOL, [])
1119 -- label in module but not function pointer, convert
1121 let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
1122 Nothing Nothing False
1123 (v1, s1) <- doExpr (pLift llvmFunTy) $
1124 Cast LM_Bitcast fun (pLift llvmFunTy)
1125 return (env, v1, unitOL s1, [])
1127 -- label not in module, create external reference
1129 let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible
1130 let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
1131 let top = CmmData Data [([],[ty'])]
1132 let env' = funInsert fn ty' env
1133 return (env', fun, nilOL, [top])
1136 -- | Create a new local var
1137 mkLocalVar :: LlvmType -> UniqSM LlvmVar
1140 return $ LMLocalVar un ty
1143 -- | Execute an expression, assigning result to a var
1144 doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement)
1147 return (v, Assignment v expr)
1150 -- | Expand CmmRegOff
1151 expandCmmReg :: (CmmReg, Int) -> CmmExpr
1152 expandCmmReg (reg, off)
1153 = let width = typeWidth (cmmRegType reg)
1154 voff = CmmLit $ CmmInt (fromIntegral off) width
1155 in CmmMachOp (MO_Add width) [CmmReg reg, voff]
1158 -- | Convert a block id into a appropriate Llvm label
1159 blockIdToLlvm :: BlockId -> LlvmVar
1160 blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
1162 -- | Create Llvm int Literal
1163 mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
1164 mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
1166 -- | Convert int type to a LLvmVar of word or i32 size
1167 toI32, toIWord :: Integral a => a -> LlvmVar
1168 toI32 = mkIntLit i32
1169 toIWord = mkIntLit llvmWord
1172 -- | Error functions
1173 panic :: String -> a
1174 panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
1176 pprPanic :: String -> SDoc -> a
1177 pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d