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 )
17 import qualified PprCmm
23 import Outputable hiding ( panic, pprPanic )
24 import qualified Outputable
29 type LlvmStatements = OrdList LlvmStatement
31 -- -----------------------------------------------------------------------------
32 -- | Top-level of the llvm proc codegen
34 genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop])
35 genLlvmProc env (CmmData _ _)
38 genLlvmProc env (CmmProc _ _ _ (ListGraph []))
41 genLlvmProc env (CmmProc info lbl params (ListGraph blocks))
43 (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
45 let proc = CmmProc info lbl params (ListGraph lmblocks)
46 let tops = lmdata ++ [proc]
51 -- -----------------------------------------------------------------------------
52 -- * Block code generation
55 -- | Generate code for a list of blocks that make up a complete procedure.
56 basicBlocksCodeGen :: LlvmEnv
58 -> ( [LlvmBasicBlock] , [LlvmCmmTop] )
59 -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmTop] )
60 basicBlocksCodeGen env ([]) (blocks, tops)
61 = do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
62 let allocs' = concat allocs
63 let ((BasicBlock id fstmts):rblocks) = blocks'
64 let fblocks = (BasicBlock id (funPrologue ++ allocs' ++ fstmts)):rblocks
65 return (env, fblocks, tops)
67 basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
68 = do (env', lb, lt) <- basicBlockCodeGen env block
69 let lblocks = lblocks' ++ lb
70 let ltops = ltops' ++ lt
71 basicBlocksCodeGen env' blocks (lblocks, ltops)
74 -- | Generate code for one block
75 basicBlockCodeGen :: LlvmEnv
77 -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmTop] )
78 basicBlockCodeGen env (BasicBlock id stmts)
79 = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
80 return (env', [BasicBlock id (fromOL instrs)], top)
83 -- | Allocations need to be extracted so they can be moved to the entry
84 -- of a function to make sure they dominate all posible paths in the CFG.
85 dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
86 dominateAllocs (BasicBlock id stmts)
87 = (BasicBlock id allstmts, allallocs)
89 (allstmts, allallocs) = foldl split ([],[]) stmts
90 split (stmts', allocs) s@(Assignment _ (Alloca _ _))
91 = (stmts', allocs ++ [s])
92 split (stmts', allocs) other
93 = (stmts' ++ [other], allocs)
96 -- -----------------------------------------------------------------------------
97 -- * CmmStmt code generation
100 -- A statement conversion return data.
101 -- * LlvmEnv: The new enviornment
102 -- * LlvmStatements: The compiled llvm statements.
103 -- * LlvmCmmTop: Any global data needed.
104 type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmTop])
107 -- | Convert a list of CmmStmt's to LlvmStatement's
108 stmtsToInstrs :: LlvmEnv -> [CmmStmt] -> (LlvmStatements, [LlvmCmmTop])
110 stmtsToInstrs env [] (llvm, top)
111 = return (env, llvm, top)
113 stmtsToInstrs env (stmt : stmts) (llvm, top)
114 = do (env', instrs, tops) <- stmtToInstrs env stmt
115 stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops)
118 -- | Convert a CmmStmt to a list of LlvmStatement's
119 stmtToInstrs :: LlvmEnv -> CmmStmt
121 stmtToInstrs env stmt = case stmt of
123 CmmNop -> return (env, nilOL, [])
124 CmmComment _ -> return (env, nilOL, []) -- nuke comments
125 -- CmmComment s -> return (env, unitOL $ Comment (lines $ unpackFS s),
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"
164 (Left [i1, i1, i1, i1, i1])
165 let fty = LMFunction funSig
167 let fv = LMGlobalVar fname fty (funcLinkage funSig)
168 let tops = case funLookup fname env of
170 Nothing -> [CmmData Data [([],[fty])]]
172 let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue]
173 let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs
174 let env' = funInsert fname fty env
176 return (env', unitOL s1, tops)
180 lmTrue = LMLitVar $ LMIntLit (-1) i1
182 -- Handle all other foreign calls and prim ops.
183 genCall env target res args ret = do
186 let arg_type (CmmHinted _ AddrHint) = pLift i8
187 -- cast pointers to i8*. Llvm equivalent of void*
188 arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType expr
191 let ret_type ([]) = LMVoid
192 ret_type ([CmmHinted _ AddrHint]) = pLift i8
193 ret_type ([CmmHinted reg _]) = cmmToLlvmType $ localRegType reg
194 ret_type t = panic $ "genCall: Too many return values! Can only handle"
195 ++ " 0 or 1, given " ++ show (length t) ++ "."
197 -- extract cmm call convention
198 let cconv = case target of
199 CmmCallee _ conv -> conv
200 CmmPrim _ -> PrimCallConv
202 -- translate to llvm call convention
203 let lmconv = case cconv of
204 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
205 StdCallConv -> CC_X86_Stdcc
207 StdCallConv -> CC_Ccc
210 PrimCallConv -> CC_Ccc
211 CmmCallConv -> panic "CmmCallConv not supported here!"
214 Some of the possibilities here are a worry with the use of a custom
215 calling convention for passing STG args. In practice the more
216 dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
218 The native code generator only handles StdCall and CCallConv.
222 let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs
223 | otherwise = llvmStdFunAttrs
226 let ccTy = StdCall -- tail calls should be done through CmmJump
227 let retTy = ret_type res
228 let argTy = Left $ map arg_type args
229 let funTy name = LMFunction $
230 LlvmFunctionDecl name ExternallyVisible lmconv retTy FixedArgs argTy
232 -- get paramter values
233 (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
235 -- get the return register
236 let ret_reg ([CmmHinted reg hint]) = (reg, hint)
237 ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
238 ++ " 1, given " ++ show (length t) ++ "."
240 -- deal with call types
241 let getFunPtr :: CmmCallTarget -> UniqSM ExprData
242 getFunPtr targ = case targ of
243 CmmCallee (CmmLit (CmmLabel lbl)) _ -> do
244 let name = strCLabel_llvm lbl
245 case funLookup name env1 of
246 Just ty'@(LMFunction sig) -> do
247 -- Function in module in right form
248 let fun = LMGlobalVar name ty' (funcLinkage sig)
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 fty (funcLinkage sig)
255 (v1, s1) <- doExpr (pLift fty)
256 $ Cast LM_Bitcast fun (pLift fty)
257 return (env1, v1, unitOL s1, [])
260 -- label not in module, create external reference
261 let fty@(LMFunction sig) = funTy name
262 let fun = LMGlobalVar name fty (funcLinkage sig)
263 let top = CmmData Data [([],[fty])]
264 let env' = funInsert name fty env1
265 return (env', fun, nilOL, [top])
267 CmmCallee expr _ -> do
268 (env', v1, stmts, top) <- exprToVar env1 expr
269 let fty = funTy $ fsLit "dynamic"
270 let cast = case getVarType v1 of
271 ty | isPointer ty -> LM_Bitcast
272 ty | isInt ty -> LM_Inttoptr
274 ty -> panic $ "genCall: Expr is of bad type for function"
275 ++ " call! (" ++ show (ty) ++ ")"
277 (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
278 return (env', v2, stmts `snocOL` s1, top)
281 let name = cmmPrimOpFunctions mop
282 let lbl = mkForeignLabel name Nothing
283 ForeignLabelInExternalPackage IsFunction
284 getFunPtr $ CmmCallee (CmmLit (CmmLabel lbl)) CCallConv
286 (env2, fptr, stmts2, top2) <- getFunPtr target
288 let retStmt | ccTy == TailCall = unitOL $ Return Nothing
289 | ret == CmmNeverReturns = unitOL $ Unreachable
292 -- make the actual call
295 let s1 = Expr $ Call ccTy fptr argVars fnAttrs
296 let allStmts = stmts1 `appOL` stmts2 `snocOL` s1 `appOL` retStmt
297 return (env2, allStmts, top1 ++ top2)
300 let (creg, _) = ret_reg res
301 let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
302 let allStmts = stmts1 `appOL` stmts2 `appOL` stmts3
303 (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
304 if retTy == pLower (getVarType vreg)
306 let s2 = Store v1 vreg
307 return (env3, allStmts `snocOL` s1 `snocOL` s2
308 `appOL` retStmt, top1 ++ top2 ++ top3)
310 let ty = pLower $ getVarType vreg
312 vt | isPointer vt -> LM_Bitcast
313 | isInt vt -> LM_Ptrtoint
315 panic $ "genCall: CmmReg bad match for"
318 (v2, s2) <- doExpr ty $ Cast op v1 ty
319 let s3 = Store v2 vreg
320 return (env3, allStmts `snocOL` s1 `snocOL` s2 `snocOL` s3
321 `appOL` retStmt, top1 ++ top2 ++ top3)
324 -- | Conversion of call arguments.
327 -> ([LlvmVar], LlvmStatements, [LlvmCmmTop])
328 -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmTop])
330 arg_vars env [] (vars, stmts, tops)
331 = return (env, vars, stmts, tops)
333 arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
334 = do (env', v1, stmts', top') <- exprToVar env e
335 let op = case getVarType v1 of
336 ty | isPointer ty -> LM_Bitcast
337 ty | isInt ty -> LM_Inttoptr
339 a -> panic $ "genCall: Can't cast llvmType to i8*! ("
342 (v2, s1) <- doExpr (pLift i8) $ Cast op v1 (pLift i8)
343 arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, tops ++ top')
345 arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
346 = do (env', v1, stmts', top') <- exprToVar env e
347 arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
349 -- | Decide what C function to use to implement a CallishMachOp
350 cmmPrimOpFunctions :: CallishMachOp -> FastString
351 cmmPrimOpFunctions mop
353 MO_F32_Exp -> fsLit "expf"
354 MO_F32_Log -> fsLit "logf"
355 MO_F32_Sqrt -> fsLit "sqrtf"
356 MO_F32_Pwr -> fsLit "powf"
358 MO_F32_Sin -> fsLit "sinf"
359 MO_F32_Cos -> fsLit "cosf"
360 MO_F32_Tan -> fsLit "tanf"
362 MO_F32_Asin -> fsLit "asinf"
363 MO_F32_Acos -> fsLit "acosf"
364 MO_F32_Atan -> fsLit "atanf"
366 MO_F32_Sinh -> fsLit "sinhf"
367 MO_F32_Cosh -> fsLit "coshf"
368 MO_F32_Tanh -> fsLit "tanhf"
370 MO_F64_Exp -> fsLit "exp"
371 MO_F64_Log -> fsLit "log"
372 MO_F64_Sqrt -> fsLit "sqrt"
373 MO_F64_Pwr -> fsLit "pow"
375 MO_F64_Sin -> fsLit "sin"
376 MO_F64_Cos -> fsLit "cos"
377 MO_F64_Tan -> fsLit "tan"
379 MO_F64_Asin -> fsLit "asin"
380 MO_F64_Acos -> fsLit "acos"
381 MO_F64_Atan -> fsLit "atan"
383 MO_F64_Sinh -> fsLit "sinh"
384 MO_F64_Cosh -> fsLit "cosh"
385 MO_F64_Tanh -> fsLit "tanh"
387 a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")"
390 -- | Tail function calls
391 genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData
393 -- Call to known function
394 genJump env (CmmLit (CmmLabel lbl)) = do
395 (env', vf, stmts, top) <- getHsFunc env lbl
396 (stgRegs, stgStmts) <- funEpilogue
397 let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
398 let s2 = Return Nothing
399 return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
402 -- Call to unknown function / address
403 genJump env expr = do
405 (env', vf, stmts, top) <- exprToVar env expr
407 let cast = case getVarType vf of
408 ty | isPointer ty -> LM_Bitcast
409 ty | isInt ty -> LM_Inttoptr
411 ty -> panic $ "genJump: Expr is of bad type for function call! ("
414 (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
415 (stgRegs, stgStmts) <- funEpilogue
416 let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
417 let s3 = Return Nothing
418 return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
422 -- | CmmAssign operation
424 -- We use stack allocated variables for CmmReg. The optimiser will replace
425 -- these with registers when possible.
426 genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData
427 genAssign env reg val = do
428 let (env1, vreg, stmts1, top1) = getCmmReg env reg
429 (env2, vval, stmts2, top2) <- exprToVar env1 val
430 let s1 = Store vval vreg
431 return (env2, stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
434 -- | CmmStore operation
435 genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
436 genStore env addr val = do
437 (env1, vaddr, stmts1, top1) <- exprToVar env addr
438 (env2, vval, stmts2, top2) <- exprToVar env1 val
439 if getVarType vaddr == llvmWord
441 let vty = pLift $ getVarType vval
442 (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
443 let s2 = Store vval vptr
444 return (env2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
448 panic $ "genStore: ptr not of word size! (" ++ show vaddr ++ ")"
451 -- | Unconditional branch
452 genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData
454 let label = blockIdToLlvm id
455 in return (env, unitOL $ Branch label, [])
458 -- | Conditional branch
459 genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData
460 genCondBranch env cond idT = do
462 let labelT = blockIdToLlvm idT
463 let labelF = LMLocalVar idF LMLabel
464 (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
465 if getVarType vc == i1
467 let s1 = BranchIf vc labelT labelF
469 return $ (env', stmts `snocOL` s1 `snocOL` s2, top)
471 panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
476 -- N.B. we remove Nothing's from the list of branches, as they are 'undefined'.
477 -- However, they may be defined one day, so we better document this behaviour.
478 genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
479 genSwitch env cond maybe_ids = do
480 (env', vc, stmts, top) <- exprToVar env cond
481 let ty = getVarType vc
483 let pairs = [ (ix, id) | (ix,Just id) <- zip ([0..]::[Integer]) maybe_ids ]
484 let labels = map (\(ix, b) -> (mkIntLit ix ty, blockIdToLlvm b)) pairs
485 -- out of range is undefied, so lets just branch to first label
486 let (_, defLbl) = head labels
488 let s1 = Switch vc defLbl labels
489 return $ (env', stmts `snocOL` s1, top)
492 -- -----------------------------------------------------------------------------
493 -- * CmmExpr code generation
496 -- | An expression conversion return data:
497 -- * LlvmEnv: The new enviornment
498 -- * LlvmVar: The var holding the result of the expression
499 -- * LlvmStatements: Any statements needed to evaluate the expression
500 -- * LlvmCmmTop: Any global data needed for this expression
501 type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmTop])
503 -- | Values which can be passed to 'exprToVar' to configure its
504 -- behaviour in certain circumstances.
505 data EOption = EOption {
506 -- | The expected LlvmType for the returned variable.
508 -- Currently just used for determining if a comparison should return
509 -- a boolean (i1) or a int (i32/i64).
510 eoExpectedType :: Maybe LlvmType
514 i1Option = EOption (Just i1)
516 wordOption :: EOption
517 wordOption = EOption (Just llvmWord)
520 -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
521 -- expression being stored in the returned LlvmVar.
522 exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
523 exprToVar env = exprToVarOpt env wordOption
525 exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
526 exprToVarOpt env opt e = case e of
532 -> genCmmLoad env e' ty
534 -- Cmmreg in expression is the value, so must load. If you want actual
535 -- reg pointer, call getCmmReg directly.
537 let (env', vreg, stmts, top) = getCmmReg env r
538 (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg
539 return (env', v1, stmts `snocOL` s1 , top)
542 -> genMachOp env opt op exprs
545 -> exprToVar env $ expandCmmReg (r, i)
548 -> panic "exprToVar: CmmStackSlot not supported!"
551 -- | Handle CmmMachOp expressions
552 genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
555 genMachOp env _ op [x] = case op of
558 let all1 = mkIntLit (-1::Int) (widthToLlvmInt w)
559 in negate (widthToLlvmInt w) all1 LM_MO_Xor
562 let all0 = mkIntLit (0::Int) (widthToLlvmInt w)
563 in negate (widthToLlvmInt w) all0 LM_MO_Sub
566 let all0 = LMLitVar $ LMFloatLit 0 (widthToLlvmFloat w)
567 in negate (widthToLlvmFloat w) all0 LM_MO_Sub
569 MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
570 MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
573 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
576 -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
579 -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
581 a -> panic $ "genMachOp: unmatched unary CmmMachOp! (" ++ show a ++ ")"
584 negate ty v2 negOp = do
585 (env', vx, stmts, top) <- exprToVar env x
586 (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
587 return (env', v1, stmts `snocOL` s1, top)
589 fiConv ty convOp = do
590 (env', vx, stmts, top) <- exprToVar env x
591 (v1, s1) <- doExpr ty $ Cast convOp vx ty
592 return (env', v1, stmts `snocOL` s1, top)
594 sameConv from ty reduce expand = do
595 x'@(env', vx, stmts, top) <- exprToVar env x
596 let sameConv' op = do
597 (v1, s1) <- doExpr ty $ Cast op vx ty
598 return (env', v1, stmts `snocOL` s1, top)
599 let toWidth = llvmWidthInBits ty
600 -- LLVM doesn't like trying to convert to same width, so
601 -- need to check for that as we do get cmm code doing it.
602 case widthInBits from of
603 w | w < toWidth -> sameConv' expand
604 w | w > toWidth -> sameConv' reduce
609 genMachOp env opt op [x, y] = case op of
611 MO_Eq _ -> genBinComp opt LM_CMP_Eq
612 MO_Ne _ -> genBinComp opt LM_CMP_Ne
614 MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
615 MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
616 MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
617 MO_S_Le _ -> genBinComp opt LM_CMP_Sle
619 MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
620 MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
621 MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
622 MO_U_Le _ -> genBinComp opt LM_CMP_Ule
624 MO_Add _ -> genBinMach LM_MO_Add
625 MO_Sub _ -> genBinMach LM_MO_Sub
626 MO_Mul _ -> genBinMach LM_MO_Mul
628 MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
630 MO_S_MulMayOflo w -> isSMulOK w x y
632 MO_S_Quot _ -> genBinMach LM_MO_SDiv
633 MO_S_Rem _ -> genBinMach LM_MO_SRem
635 MO_U_Quot _ -> genBinMach LM_MO_UDiv
636 MO_U_Rem _ -> genBinMach LM_MO_URem
638 MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
639 MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
640 MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
641 MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
642 MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
643 MO_F_Le _ -> genBinComp opt LM_CMP_Fle
645 MO_F_Add _ -> genBinMach LM_MO_Add
646 MO_F_Sub _ -> genBinMach LM_MO_Sub
647 MO_F_Mul _ -> genBinMach LM_MO_Mul
648 MO_F_Quot _ -> genBinMach LM_MO_FDiv
650 MO_And _ -> genBinMach LM_MO_And
651 MO_Or _ -> genBinMach LM_MO_Or
652 MO_Xor _ -> genBinMach LM_MO_Xor
653 MO_Shl _ -> genBinMach LM_MO_Shl
654 MO_U_Shr _ -> genBinMach LM_MO_LShr
655 MO_S_Shr _ -> genBinMach LM_MO_AShr
657 a -> panic $ "genMachOp: unmatched binary CmmMachOp! (" ++ show a ++ ")"
660 binLlvmOp ty binOp = do
661 (env1, vx, stmts1, top1) <- exprToVar env x
662 (env2, vy, stmts2, top2) <- exprToVar env1 y
663 if getVarType vx == getVarType vy
665 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
666 return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1,
670 -- XXX: Error. Continue anyway so we can debug the generated
672 let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr)
673 let dx = Comment $ map fsLit $ cmmToStr x
674 let dy = Comment $ map fsLit $ cmmToStr y
675 (v1, s1) <- doExpr (ty vx) $ binOp vx vy
676 let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
677 `snocOL` dy `snocOL` s1
678 return (env2, v1, allStmts, top1 ++ top2)
680 -- let o = case binOp vx vy of
681 -- Compare op _ _ -> show op
682 -- LlvmOp op _ _ -> show op
684 -- panic $ "genMachOp: comparison between different types ("
685 -- ++ o ++ " "++ show vx ++ ", " ++ show vy ++ ")"
686 -- ++ "\ne1: " ++ (show.llvmSDoc.PprCmm.pprExpr $ x)
687 -- ++ "\ne2: " ++ (show.llvmSDoc.PprCmm.pprExpr $ y)
689 -- | Need to use EOption here as Cmm expects word size results from
690 -- comparisons while llvm return i1. Need to extend to llvmWord type
692 genBinComp opt cmp = do
693 ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) $ Compare cmp
695 if getVarType v1 == i1
697 case eoExpectedType opt of
705 (v2, s1) <- doExpr t $ Cast LM_Zext v1 t
706 return (env', v2, stmts `snocOL` s1, top)
709 panic $ "genBinComp: Can't case i1 compare"
710 ++ "res to non int type " ++ show (t)
712 panic $ "genBinComp: Compare returned type other then i1! "
713 ++ (show $ getVarType v1)
715 genBinMach op = binLlvmOp getVarType (LlvmOp op)
717 -- | Detect if overflow will occur in signed multiply of the two
718 -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
719 -- implementation. Its much longer due to type information/safety.
720 -- This should actually compile to only about 3 asm instructions.
721 isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData
723 (env1, vx, stmts1, top1) <- exprToVar env x
724 (env2, vy, stmts2, top2) <- exprToVar env1 y
726 let word = getVarType vx
727 let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx)
728 let shift = llvmWidthInBits word
729 let shift1 = mkIntLit (shift - 1) llvmWord
730 let shift2 = mkIntLit shift llvmWord
734 (x1, s1) <- doExpr word2 $ Cast LM_Sext vx word2
735 (y1, s2) <- doExpr word2 $ Cast LM_Sext vy word2
736 (r1, s3) <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
737 (rlow1, s4) <- doExpr word $ Cast LM_Trunc r1 word
738 (rlow2, s5) <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
739 (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
740 (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
741 (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
742 let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
743 `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
744 return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts,
748 panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"
751 -- More then two expression, invalid!
752 genMachOp _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
755 -- | Handle CmmLoad expression
756 genCmmLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
757 genCmmLoad env e ty = do
758 (env', iptr, stmts, tops) <- exprToVar env e
759 let ety = getVarType iptr
761 True | llvmPtrBits == llvmWidthInBits ety -> do
762 let pty = LMPointer $ cmmToLlvmType ty
763 (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty
764 (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr
765 return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
769 ("exprToVar: can't cast to pointer as int not of "
771 (PprCmm.pprExpr e <+> text (
772 "Size of Ptr: " ++ show llvmPtrBits ++
773 ", Size of var: " ++ show (llvmWidthInBits ety) ++
774 ", Var: " ++ show iptr))
776 False -> panic "exprToVar: CmmLoad expression is not of type int!"
779 -- | Handle CmmReg expression
781 -- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an
782 -- equivalent SSA form and avoids having to deal with Phi node insertion.
783 -- This is also the approach recommended by llvm developers.
784 getCmmReg :: LlvmEnv -> CmmReg -> ExprData
785 getCmmReg env r@(CmmLocal (LocalReg un _))
786 = let exists = varLookup un env
788 (newv, stmts) = allocReg r
789 nenv = varInsert un (pLower $ getVarType newv) env
791 Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, [])
792 Nothing -> (nenv, newv, stmts, [])
794 getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar g, nilOL, [])
797 -- | Allocate a CmmReg on the stack
798 allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
799 allocReg (CmmLocal (LocalReg un ty))
800 = let ty' = cmmToLlvmType ty
801 var = LMLocalVar un (LMPointer ty')
803 in (var, unitOL $ Assignment var alc)
805 allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
806 ++ " have been handled elsewhere!"
809 -- | Generate code for a literal
810 genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData
811 genLit env (CmmInt i w)
812 = return (env, mkIntLit i (LMInt $ widthInBits w), nilOL, [])
814 genLit env (CmmFloat r w)
815 = return (env, LMLitVar $ LMFloatLit r (widthToLlvmFloat w), nilOL, [])
817 genLit env cmm@(CmmLabel l)
818 = let label = strCLabel_llvm l
819 ty = funLookup label env
820 lmty = cmmToLlvmType $ cmmLitType cmm
822 -- Make generic external label defenition and then pointer to it
824 let glob@(var, _) = genStringLabelRef label
825 let ldata = [CmmData Data [([glob], [])]]
826 let env' = funInsert label (pLower $ getVarType var) env
827 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
828 return (env', v1, unitOL s1, ldata)
829 -- Referenced data exists in this module, retrieve type and make
832 let var = LMGlobalVar label (LMPointer ty') ExternallyVisible
833 (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
834 return (env, v1, unitOL s1, [])
836 genLit env (CmmLabelOff label off) = do
837 (env', vlbl, stmts, stat) <- genLit env (CmmLabel label)
838 let voff = mkIntLit off llvmWord
839 (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
840 return (env', v1, stmts `snocOL` s1, stat)
842 genLit env (CmmLabelDiffOff l1 l2 off) = do
843 (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1)
844 (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2)
845 let voff = mkIntLit off llvmWord
846 let ty1 = getVarType vl1
847 let ty2 = getVarType vl2
848 if (isInt ty1) && (isInt ty2)
849 && (llvmWidthInBits ty1 == llvmWidthInBits ty2)
852 (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
853 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
854 return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
858 panic "genLit: CmmLabelDiffOff encountered with different label ty!"
860 genLit env (CmmBlock b)
861 = genLit env (CmmLabel $ infoTblLbl b)
863 genLit _ CmmHighStackMark
864 = panic "genStaticLit - CmmHighStackMark unsupported!"
867 -- -----------------------------------------------------------------------------
871 -- | Function prologue. Load STG arguments into variables for function.
872 funPrologue :: [LlvmStatement]
873 funPrologue = concat $ map getReg activeStgRegs
875 let reg = lmGlobalRegVar rr
876 arg = lmGlobalRegArg rr
877 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
878 store = Store arg reg
882 -- | Function epilogue. Load STG variables to use as argument for call.
883 funEpilogue :: UniqSM ([LlvmVar], LlvmStatements)
886 (v,s) <- doExpr (pLower $ getVarType r) $ Load r
888 loads <- mapM (loadExpr . lmGlobalRegVar) activeStgRegs
889 let (vars, stmts) = unzip loads
890 return (vars, concatOL stmts)
893 -- | Get a function pointer to the CLabel specified.
895 -- This is for Haskell functions, function type is assumed, so doesn't work
896 -- with foreign functions.
897 getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData
899 = let fname = strCLabel_llvm lbl
900 ty = funLookup fname env
902 Just ty'@(LMFunction sig) -> do
903 -- Function in module in right form
904 let fun = LMGlobalVar fname ty' (funcLinkage sig)
905 return (env, fun, nilOL, [])
907 -- label in module but not function pointer, convert
908 let fun = LMGlobalVar fname (pLift ty') ExternallyVisible
909 (v1, s1) <- doExpr (pLift llvmFunTy) $ Cast LM_Bitcast fun (pLift llvmFunTy)
910 return (env, v1, unitOL s1, [])
912 -- label not in module, create external reference
913 let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible
914 let fun = LMGlobalVar fname ty' ExternallyVisible
915 let top = CmmData Data [([],[ty'])]
916 let env' = funInsert fname ty' env
917 return (env', fun, nilOL, [top])
920 -- | Create a new local var
921 mkLocalVar :: LlvmType -> UniqSM LlvmVar
924 return $ LMLocalVar un ty
927 -- | Execute an expression, assigning result to a var
928 doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement)
931 return (v, Assignment v expr)
934 -- | Expand CmmRegOff
935 expandCmmReg :: (CmmReg, Int) -> CmmExpr
936 expandCmmReg (reg, off)
937 = let width = typeWidth (cmmRegType reg)
938 voff = CmmLit $ CmmInt (fromIntegral off) width
939 in CmmMachOp (MO_Add width) [CmmReg reg, voff]
942 -- | Convert a block id into a appropriate Llvm label
943 blockIdToLlvm :: BlockId -> LlvmVar
944 blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
947 -- | Create Llvm int Literal
948 mkIntLit :: Integral a => a -> LlvmType -> LlvmVar
949 mkIntLit i ty = LMLitVar $ LMIntLit (toInteger i) ty
954 panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
956 pprPanic :: String -> SDoc -> a
957 pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d