Generate correct LLVM for the new register allocation scheme.

We now have accurate global register liveness information attached to all Cmm
procedures and jumps. With this patch, the LLVM back end uses this information
to pass only the live floating point (F and D) registers on tail calls. This
makes the LLVM back end compatible with the new register allocation strategy.

Ideally the GHC LLVM calling convention would put all registers that are always
live first in the parameter sequence. Unfortunately the specification is written
so that on x86-64 SpLim (always live) is passed after the R registers. Therefore
we must always pass *something* in the R registers, so we pass the LLVM value
undef.
parent e2f6bbd3
......@@ -41,11 +41,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 _ _) (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
env' = funInsert lbl (llvmFunTy dflags) e
env' = funInsert lbl (llvmFunTy dflags live) e
in (d,env')
in do
showPass dflags "LlVM CodeGen"
......
......@@ -7,6 +7,7 @@
module LlvmCodeGen.Base (
LlvmCmmDecl, LlvmBasicBlock,
LiveGlobalRegs,
LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion,
......@@ -46,6 +47,9 @@ import Unique
type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement)
type LlvmBasicBlock = GenBasicBlock LlvmStatement
-- | Global registers live on proc entry
type LiveGlobalRegs = [GlobalReg]
-- | Unresolved code.
-- Of the form: (data label, data type, unresolved data)
type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
......@@ -88,29 +92,29 @@ llvmGhcCC dflags
| otherwise = CC_Ncc 10
-- | Llvm Function type for Cmm function
llvmFunTy :: DynFlags -> LlvmType
llvmFunTy dflags = LMFunction $ llvmFunSig' dflags (fsLit "a") ExternallyVisible
llvmFunTy :: DynFlags -> LiveGlobalRegs -> LlvmType
llvmFunTy dflags live = LMFunction $ llvmFunSig' dflags live (fsLit "a") ExternallyVisible
-- | Llvm Function signature
llvmFunSig :: LlvmEnv -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl
llvmFunSig env lbl link
= llvmFunSig' (getDflags env) (strCLabel_llvm env lbl) link
llvmFunSig :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl
llvmFunSig env live lbl link
= llvmFunSig' (getDflags env) live (strCLabel_llvm env lbl) link
llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl
llvmFunSig' dflags lbl link
llvmFunSig' :: DynFlags -> LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmFunctionDecl
llvmFunSig' dflags live lbl link
= let toParams x | isPointer x = (x, [NoAlias, NoCapture])
| otherwise = (x, [])
in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
(map (toParams . getVarType) (llvmFunArgs dflags))
(map (toParams . getVarType) (llvmFunArgs dflags live))
(llvmFunAlign dflags)
-- | Create a Haskell function in LLVM.
mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
mkLlvmFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
-> LlvmFunction
mkLlvmFunc env lbl link sec blks
mkLlvmFunc env live lbl link sec blks
= let dflags = getDflags env
funDec = llvmFunSig env lbl link
funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags)
funDec = llvmFunSig env live lbl link
funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags live)
in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
-- | Alignment to use for functions
......@@ -122,9 +126,15 @@ llvmInfAlign :: DynFlags -> LMAlign
llvmInfAlign dflags = Just (wORD_SIZE dflags)
-- | A Function's arguments
llvmFunArgs :: DynFlags -> [LlvmVar]
llvmFunArgs dflags = map (lmGlobalRegArg dflags) (activeStgRegs platform)
llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs dflags live =
map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform))
where platform = targetPlatform dflags
isLive r = not (isFloat r) || r `elem` alwaysLive || r `elem` live
isPassed r = not (isFloat r) || isLive r
isFloat (FloatReg _) = True
isFloat (DoubleReg _) = True
isFloat _ = False
-- | Llvm standard fun attributes
llvmStdFunAttrs :: [LlvmFuncAttr]
......
......@@ -38,7 +38,7 @@ type LlvmStatements = OrdList LlvmStatement
--
genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl])
genLlvmProc env proc0@(CmmProc _ lbl live (ListGraph blocks)) = do
(env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
(env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], [])
let info = topInfoTable proc0
proc = CmmProc info lbl live (ListGraph lmblocks)
return (env', proc:lmdata)
......@@ -51,22 +51,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]
-> ( [LlvmBasicBlock] , [LlvmCmmDecl] )
-> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] )
basicBlocksCodeGen env ([]) (blocks, tops)
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 ++ allocs' ++ fstmts):rblks
let fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks
return (env, fblocks, tops)
basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
basicBlocksCodeGen env live (block:blocks) (lblocks', ltops')
= do (env', lb, lt) <- basicBlockCodeGen env block
let lblocks = lblocks' ++ lb
let ltops = ltops' ++ lt
basicBlocksCodeGen env' blocks (lblocks, ltops)
basicBlocksCodeGen env' live blocks (lblocks, ltops)
-- | Allocations need to be extracted so they can be moved to the entry
......@@ -514,7 +515,7 @@ genJump :: LlvmEnv -> CmmExpr -> [GlobalReg] -> UniqSM StmtData
-- Call to known function
genJump env (CmmLit (CmmLabel lbl)) live = do
(env', vf, stmts, top) <- getHsFunc env lbl
(env', vf, stmts, top) <- getHsFunc env live lbl
(stgRegs, stgStmts) <- funEpilogue env live
let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
let s2 = Return Nothing
......@@ -523,7 +524,7 @@ genJump env (CmmLit (CmmLabel lbl)) live = do
-- Call to unknown function / address
genJump env expr live = do
let fty = llvmFunTy (getDflags env)
let fty = llvmFunTy (getDflags env) live
(env', vf, stmts, top) <- exprToVar env expr
let cast = case getVarType vf of
......@@ -1246,29 +1247,40 @@ genLit _ CmmHighStackMark
--
-- | Function prologue. Load STG arguments into variables for function.
funPrologue :: DynFlags -> [LlvmStatement]
funPrologue dflags = concat $ map getReg $ activeStgRegs platform
funPrologue :: DynFlags -> LiveGlobalRegs -> [LlvmStatement]
funPrologue dflags live = concat $ map getReg $ activeStgRegs platform
where platform = targetPlatform dflags
isLive r = r `elem` alwaysLive || r `elem` live
getReg rr =
let reg = lmGlobalRegVar dflags rr
arg = lmGlobalRegArg dflags rr
ty = (pLower . getVarType) reg
trash = LMLitVar $ LMUndefLit ty
alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
in [alloc, Store arg reg]
in
if isLive rr
then [alloc, Store arg reg]
else [alloc, Store trash reg]
-- | Function epilogue. Load STG variables to use as argument for call.
-- STG Liveness optimisation done here.
funEpilogue :: LlvmEnv -> [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements)
funEpilogue :: LlvmEnv -> LiveGlobalRegs -> UniqSM ([LlvmVar], LlvmStatements)
-- Have information and liveness optimisation is enabled
funEpilogue env live | gopt Opt_RegLiveness dflags = do
loads <- mapM loadExpr (activeStgRegs platform)
funEpilogue env live = do
loads <- mapM loadExpr (filter isPassed (activeStgRegs platform))
let (vars, stmts) = unzip loads
return (vars, concatOL stmts)
where
dflags = getDflags env
platform = targetPlatform dflags
loadExpr r | r `elem` alwaysLive || r `elem` live = do
isLive r = r `elem` alwaysLive || r `elem` live
isPassed r = not (isFloat r) || isLive r
isFloat (FloatReg _) = True
isFloat (DoubleReg _) = True
isFloat _ = False
loadExpr r | isLive r = do
let reg = lmGlobalRegVar dflags r
(v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
return (v, unitOL s)
......@@ -1276,19 +1288,6 @@ funEpilogue env live | gopt Opt_RegLiveness dflags = do
let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
return (LMLitVar $ LMUndefLit ty, unitOL Nop)
-- don't do liveness optimisation
funEpilogue env _ = do
loads <- mapM loadExpr (activeStgRegs platform)
let (vars, stmts) = unzip loads
return (vars, concatOL stmts)
where
dflags = getDflags env
platform = targetPlatform dflags
loadExpr r = do
let reg = lmGlobalRegVar dflags r
(v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
return (v, unitOL s)
-- | A serries of statements to trash all the STG registers.
--
......@@ -1317,8 +1316,8 @@ trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform
--
-- This is for Haskell functions, function type is assumed, so doesn't work
-- with foreign functions.
getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData
getHsFunc env lbl
getHsFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> UniqSM ExprData
getHsFunc env live lbl
= let dflags = getDflags env
fn = strCLabel_llvm env lbl
ty = funLookup fn env
......@@ -1332,13 +1331,13 @@ getHsFunc env lbl
Just ty' -> do
let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
Nothing Nothing False
(v1, s1) <- doExpr (pLift (llvmFunTy dflags)) $
Cast LM_Bitcast fun (pLift (llvmFunTy dflags))
(v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $
Cast LM_Bitcast fun (pLift (llvmFunTy dflags live))
return (env, v1, unitOL s1, [])
-- label not in module, create external reference
Nothing -> do
let ty' = LMFunction $ llvmFunSig env lbl ExternallyVisible
let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible
let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
let top = CmmData Data [([],[ty'])]
let env' = funInsert fn ty' env
......
......@@ -83,7 +83,7 @@ pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar])
pprLlvmCmmDecl _ _ (CmmData _ lmdata)
= (vcat $ map pprLlvmData lmdata, [])
pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl _ (ListGraph blks))
pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl live (ListGraph blks))
= let (idoc, ivar) = case mb_info of
Nothing -> (empty, [])
Just (Statics info_lbl dat)
......@@ -98,7 +98,7 @@ pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl _ (ListGraph blks))
else Internal
lmblocks = map (\(BasicBlock id stmts) ->
LlvmBlock (getUnique id) stmts) blks
fun = mkLlvmFunc env lbl' link sec' lmblocks
fun = mkLlvmFunc env live lbl' link sec' lmblocks
in ppLlvmFunction fun
), ivar)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment