summaryrefslogtreecommitdiff
path: root/compiler/llvmGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/llvmGen')
-rw-r--r--compiler/llvmGen/LlvmCodeGen.hs17
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Base.hs2
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs197
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Data.hs2
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Ppr.hs2
5 files changed, 113 insertions, 107 deletions
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 571348f577..241e52e392 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -14,8 +14,9 @@ import LlvmCodeGen.Ppr
import LlvmMangler
import CgUtils ( fixStgRegisters )
-import OldCmm
-import OldPprCmm
+import Cmm
+import Hoopl
+import PprCmm
import BufWrite
import DynFlags
@@ -41,10 +42,11 @@ llvmCodeGen dflags h us cmms
(cdata,env) = {-# SCC "llvm_split" #-}
foldr split ([], initLlvmEnv dflags) cmm
split (CmmData s d' ) (d,e) = ((s,d'):d,e)
- split p@(CmmProc _ l live _) (d,e) =
- let lbl = strCLabel_llvm env $ case topInfoTable p of
- Nothing -> l
- Just (Statics info_lbl _) -> info_lbl
+ split p@(CmmProc h l live g) (d,e) =
+ let lbl = strCLabel_llvm env $
+ case mapLookup (g_entry g) h of
+ Nothing -> l
+ Just (Statics info_lbl _) -> info_lbl
env' = funInsert lbl (llvmFunTy dflags live) e
in (d,env')
in do
@@ -129,9 +131,6 @@ cmmProcLlvmGens dflags h _ _ [] _ ivars
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
= cmmProcLlvmGens dflags h us env cmms count ivars
-cmmProcLlvmGens dflags h us env ((CmmProc _ _ _ (ListGraph [])) : cmms) count ivars
- = cmmProcLlvmGens dflags h us env cmms count ivars
-
cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
(us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 849e40d203..56537d2ae2 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -34,7 +34,7 @@ import CLabel
import CodeGen.Platform ( activeStgRegs )
import DynFlags
import FastString
-import OldCmm
+import Cmm
import qualified Outputable as Outp
import Platform
import UniqFM
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index d62fbf4397..b5d4b4a76c 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -3,6 +3,7 @@
-- | Handle conversion of CmmProc to LLVM code.
--
+{-# LANGUAGE GADTs #-}
module LlvmCodeGen.CodeGen ( genLlvmProc ) where
#include "HsVersions.h"
@@ -14,8 +15,10 @@ import LlvmCodeGen.Regs
import BlockId
import CodeGen.Platform ( activeStgRegs, callerSaves )
import CLabel
-import OldCmm
-import qualified OldPprCmm as PprCmm
+import Cmm
+import PprCmm
+import CmmUtils
+import Hoopl
import DynFlags
import FastString
@@ -37,9 +40,10 @@ type LlvmStatements = OrdList LlvmStatement
-- | Top-level of the LLVM proc Code generator
--
genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl])
-genLlvmProc env proc0@(CmmProc _ lbl live (ListGraph blocks)) = do
+genLlvmProc env proc0@(CmmProc infos lbl live graph) = do
+ let blocks = toBlockList graph
(env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], [])
- let info = topInfoTable proc0
+ let info = mapLookup (g_entry graph) infos
proc = CmmProc info lbl live (ListGraph lmblocks)
return (env', proc:lmdata)
@@ -52,22 +56,23 @@ genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!"
-- | Generate code for a list of blocks that make up a complete procedure.
basicBlocksCodeGen :: LlvmEnv
-> LiveGlobalRegs
- -> [CmmBasicBlock]
+ -> [CmmBlock]
-> ( [LlvmBasicBlock] , [LlvmCmmDecl] )
-> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] )
-basicBlocksCodeGen env live ([]) (blocks, tops)
- = do let dflags = getDflags env
- let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
- let allocs' = concat allocs
- let ((BasicBlock id fstmts):rblks) = blocks'
- let fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks
- return (env, fblocks, tops)
-
-basicBlocksCodeGen env live (block:blocks) (lblocks', ltops')
+basicBlocksCodeGen env live [] (blocks0, tops0)
+ = return (env, fblocks, tops)
+ where
+ dflags = getDflags env
+ blocks = reverse blocks0
+ tops = reverse tops0
+ (blocks', allocs) = mapAndUnzip dominateAllocs blocks
+ allocs' = concat allocs
+ (BasicBlock id fstmts : rblks) = blocks'
+ fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks
+
+basicBlocksCodeGen env live (block:blocks) (lblocks, ltops)
= do (env', lb, lt) <- basicBlockCodeGen env block
- let lblocks = lblocks' ++ lb
- let ltops = ltops' ++ lt
- basicBlocksCodeGen env' live blocks (lblocks, ltops)
+ basicBlocksCodeGen env' live blocks (lb : lblocks, reverse lt ++ ltops)
-- | Allocations need to be extracted so they can be moved to the entry
@@ -81,16 +86,19 @@ dominateAllocs (BasicBlock id stmts)
-- | Generate code for one block
-basicBlockCodeGen :: LlvmEnv
- -> CmmBasicBlock
- -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmDecl] )
-basicBlockCodeGen env (BasicBlock id stmts)
- = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
- return (env', [BasicBlock id (fromOL instrs)], top)
-
+basicBlockCodeGen :: LlvmEnv
+ -> CmmBlock
+ -> UniqSM ( LlvmEnv, LlvmBasicBlock, [LlvmCmmDecl] )
+basicBlockCodeGen env block
+ = do let (CmmEntry id, nodes, tail) = blockSplit block
+ let stmts = blockToList nodes
+ (env', mid_instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
+ (env'', tail_instrs, top') <- stmtToInstrs env' tail
+ let instrs = fromOL (mid_instrs `appOL` tail_instrs)
+ return (env'', BasicBlock id instrs, top' ++ top)
-- -----------------------------------------------------------------------------
--- * CmmStmt code generation
+-- * CmmNode code generation
--
-- A statement conversion return data.
@@ -100,8 +108,8 @@ basicBlockCodeGen env (BasicBlock id stmts)
type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmDecl])
--- | Convert a list of CmmStmt's to LlvmStatement's
-stmtsToInstrs :: LlvmEnv -> [CmmStmt] -> (LlvmStatements, [LlvmCmmDecl])
+-- | Convert a list of CmmNode's to LlvmStatement's
+stmtsToInstrs :: LlvmEnv -> [CmmNode e x] -> (LlvmStatements, [LlvmCmmDecl])
-> UniqSM StmtData
stmtsToInstrs env [] (llvm, top)
= return (env, llvm, top)
@@ -111,34 +119,28 @@ stmtsToInstrs env (stmt : stmts) (llvm, top)
stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops)
--- | Convert a CmmStmt to a list of LlvmStatement's
-stmtToInstrs :: LlvmEnv -> CmmStmt
+-- | Convert a CmmNode to a list of LlvmStatement's
+stmtToInstrs :: LlvmEnv -> CmmNode e x
-> UniqSM StmtData
stmtToInstrs env stmt = case stmt of
- CmmNop -> return (env, nilOL, [])
CmmComment _ -> return (env, nilOL, []) -- nuke comments
CmmAssign reg src -> genAssign env reg src
CmmStore addr src -> genStore env addr src
CmmBranch id -> genBranch env id
- CmmCondBranch arg id -> genCondBranch env arg id
+ CmmCondBranch arg true false -> genCondBranch env arg true false
CmmSwitch arg ids -> genSwitch env arg ids
-- Foreign Call
- CmmCall target res args ret
- -> genCall env target res args ret
+ CmmUnsafeForeignCall target res args -> genCall env target res args
-- Tail call
- CmmJump arg live -> genJump env arg live
-
- -- CPS, only tail calls, no return's
- -- Actually, there are a few return statements that occur because of hand
- -- written Cmm code.
- CmmReturn
- -> return (env, unitOL $ Return Nothing, [])
+ CmmCall { cml_target = arg,
+ cml_args_regs = live } -> genJump env arg live
+ _ -> panic "Llvm.CodeGen.stmtToInstrs"
-- | Memory barrier instruction for LLVM >= 3.0
barrier :: LlvmEnv -> UniqSM StmtData
@@ -171,12 +173,12 @@ oldBarrier env = do
lmTrue = mkIntLit i1 (-1)
-- | Foreign Calls
-genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual]
- -> CmmReturnInfo -> UniqSM StmtData
+genCall :: LlvmEnv -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+ -> UniqSM StmtData
-- Write barrier needs to be handled specially as it is implemented as an LLVM
-- intrinsic function.
-genCall env (CmmPrim MO_WriteBarrier _) _ _ _
+genCall env (PrimTarget MO_WriteBarrier) _ _
| platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC]
= return (env, nilOL, [])
| getLlvmVer env > 29 = barrier env
@@ -186,7 +188,7 @@ genCall env (CmmPrim MO_WriteBarrier _) _ _ _
-- types and things like Word8 are backed by an i32 and just present a logical
-- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM
-- is strict about types.
-genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
+genCall env t@(PrimTarget (MO_PopCnt w)) [dst] args = do
let dflags = getDflags env
width = widthToLlvmInt w
dstTy = cmmToLlvmType $ localRegType dst
@@ -194,7 +196,9 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
CC_Ccc width FixedArgs (tysToParams [width]) Nothing
(env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst)
- (env2, argsV, stmts2, top2) <- arg_vars env1 args ([], nilOL, [])
+ let (_, arg_hints) = foreignTargetHints t
+ let args_hints = zip args arg_hints
+ (env2, argsV, stmts2, top2) <- arg_vars env1 args_hints ([], nilOL, [])
(env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t
(argsV', stmts4) <- castVars dflags $ zip argsV [width]
(retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
@@ -207,7 +211,7 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
-genCall env t@(CmmPrim op _) [] args' CmmMayReturn
+genCall env t@(PrimTarget op) [] args'
| op == MO_Memcpy ||
op == MO_Memset ||
op == MO_Memmove = do
@@ -220,7 +224,9 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn
funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
- (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
+ let (_, arg_hints) = foreignTargetHints t
+ let args_hints = zip args arg_hints
+ (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, [])
(env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t
(argVars', stmts3) <- castVars dflags $ zip argVars argTy
@@ -236,48 +242,43 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn
-- Fix for trac #6158. Since LLVM 3.1, opt fails when given anything other
-- than a direct constant (i.e. 'i32 8') as the alignment argument for the
-- memcpy & co llvm intrinsic functions. So we handle this directly now.
- extractLit (CmmHinted (CmmLit (CmmInt i _)) _) = mkIntLit i32 i
+ extractLit (CmmLit (CmmInt i _)) = mkIntLit i32 i
extractLit _other = trace ("WARNING: Non constant alignment value given" ++
" for memcpy! Please report to GHC developers")
mkIntLit i32 0
-genCall env (CmmPrim _ (Just stmts)) _ _ _
- = stmtsToInstrs env stmts (nilOL, [])
-
-- Handle all other foreign calls and prim ops.
-genCall env target res args ret = do
+genCall env target res args = do
let dflags = getDflags env
-- parameter types
- let arg_type (CmmHinted _ AddrHint) = i8Ptr
+ let arg_type (_, AddrHint) = i8Ptr
-- cast pointers to i8*. Llvm equivalent of void*
- arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType dflags expr
+ arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr
-- ret type
- let ret_type ([]) = LMVoid
- ret_type ([CmmHinted _ AddrHint]) = i8Ptr
- ret_type ([CmmHinted reg _]) = cmmToLlvmType $ localRegType reg
+ let ret_type [] = LMVoid
+ ret_type [(_, AddrHint)] = i8Ptr
+ ret_type [(reg, _)] = cmmToLlvmType $ localRegType reg
ret_type t = panic $ "genCall: Too many return values! Can only handle"
++ " 0 or 1, given " ++ show (length t) ++ "."
- -- extract Cmm call convention
- let cconv = case target of
- CmmCallee _ conv -> conv
- CmmPrim _ _ -> PrimCallConv
-
- -- translate to LLVM call convention
- let lmconv = case cconv of
- StdCallConv -> case platformArch (getLlvmPlatform env) of
- ArchX86 -> CC_X86_Stdcc
- ArchX86_64 -> CC_X86_Stdcc
- _ -> CC_Ccc
- CCallConv -> CC_Ccc
- CApiConv -> CC_Ccc
- PrimCallConv -> CC_Ccc
+ -- extract Cmm call convention, and translate to LLVM call convention
+ let lmconv = case target of
+ ForeignTarget _ (ForeignConvention conv _ _ _) ->
+ case conv of
+ StdCallConv -> case platformArch (getLlvmPlatform env) of
+ ArchX86 -> CC_X86_Stdcc
+ ArchX86_64 -> CC_X86_Stdcc
+ _ -> CC_Ccc
+ CCallConv -> CC_Ccc
+ CApiConv -> CC_Ccc
+
+ PrimTarget _ -> CC_Ccc
{-
- Some of the possibilities here are a worry with the use of a custom
+ CC_Ccc of the possibilities here are a worry with the use of a custom
calling convention for passing STG args. In practice the more
dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
@@ -285,23 +286,31 @@ genCall env target res args ret = do
-}
-- call attributes
- let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs
- | otherwise = llvmStdFunAttrs
+ let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs
+ | otherwise = llvmStdFunAttrs
+
+ never_returns = case target of
+ ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True
+ _ -> False
-- fun type
+ let (res_hints, arg_hints) = foreignTargetHints target
+ let args_hints = zip args arg_hints
+ let ress_hints = zip res res_hints
let ccTy = StdCall -- tail calls should be done through CmmJump
- let retTy = ret_type res
- let argTy = tysToParams $ map arg_type args
+ let retTy = ret_type ress_hints
+ let argTy = tysToParams $ map arg_type args_hints
let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
- (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
+
+ (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, [])
(env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target
- let retStmt | ccTy == TailCall = unitOL $ Return Nothing
- | ret == CmmNeverReturns = unitOL $ Unreachable
- | otherwise = nilOL
+ let retStmt | ccTy == TailCall = unitOL $ Return Nothing
+ | never_returns = unitOL $ Unreachable
+ | otherwise = nilOL
let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts (getDflags env)
@@ -315,10 +324,10 @@ genCall env target res args ret = do
_ -> do
(v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
-- get the return register
- let ret_reg ([CmmHinted reg hint]) = (reg, hint)
+ let ret_reg [reg] = reg
ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
++ " 1, given " ++ show (length t) ++ "."
- let (creg, _) = ret_reg res
+ let creg = ret_reg res
let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
let allStmts = stmts `snocOL` s1 `appOL` stmts3
if retTy == pLower (getVarType vreg)
@@ -342,12 +351,12 @@ genCall env target res args ret = do
-- | Create a function pointer from a target.
-getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget
+getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> ForeignTarget
-> UniqSM ExprData
getFunPtr env funTy targ = case targ of
- CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl
+ ForeignTarget (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl
- CmmCallee expr _ -> do
+ ForeignTarget expr _ -> do
(env', v1, stmts, top) <- exprToVar env expr
let fty = funTy $ fsLit "dynamic"
cast = case getVarType v1 of
@@ -360,7 +369,7 @@ getFunPtr env funTy targ = case targ of
(v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
return (env', v2, stmts `snocOL` s1, top)
- CmmPrim mop _ -> litCase $ cmmPrimOpFunctions env mop
+ PrimTarget mop -> litCase $ cmmPrimOpFunctions env mop
where
litCase name = do
@@ -392,14 +401,14 @@ getFunPtr env funTy targ = case targ of
-- | Conversion of call arguments.
arg_vars :: LlvmEnv
- -> [HintedCmmActual]
+ -> [(CmmActual, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmDecl])
arg_vars env [] (vars, stmts, tops)
= return (env, vars, stmts, tops)
-arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
+arg_vars env ((e, AddrHint):rest) (vars, stmts, tops)
= do (env', v1, stmts', top') <- exprToVar env e
let op = case getVarType v1 of
ty | isPointer ty -> LM_Bitcast
@@ -412,7 +421,7 @@ arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
tops ++ top')
-arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
+arg_vars env ((e, _):rest) (vars, stmts, tops)
= do (env', v1, stmts', top') <- exprToVar env e
arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
@@ -673,17 +682,15 @@ genBranch env id =
-- | Conditional branch
-genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData
-genCondBranch env cond idT = do
- idF <- getUniqueUs
+genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData
+genCondBranch env cond idT idF = do
let labelT = blockIdToLlvm idT
- let labelF = LMLocalVar idF LMLabel
+ let labelF = blockIdToLlvm idF
(env', vc, stmts, top) <- exprToVarOpt env i1Option cond
if getVarType vc == i1
then do
let s1 = BranchIf vc labelT labelF
- let s2 = MkLabel idF
- return $ (env', stmts `snocOL` s1 `snocOL` s2, top)
+ return $ (env', stmts `snocOL` s1, top)
else
panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index 9c57ab3cd4..fd0d7ccd99 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -13,7 +13,7 @@ import LlvmCodeGen.Base
import BlockId
import CLabel
-import OldCmm
+import Cmm
import FastString
import qualified Outputable
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 73632f5fd4..218870a5b8 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -14,7 +14,7 @@ import LlvmCodeGen.Data
import LlvmCodeGen.Regs
import CLabel
-import OldCmm
+import Cmm
import Platform
import FastString
View Lorry Controller Status