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.

4 files changed, 59 insertions, 50 deletions

diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 9a5ac1f522..571348f577 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -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"
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 86fab77ad9..849e40d203 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -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]
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 885d4aa127..d62fbf4397 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -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
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 781215adf4..73632f5fd4 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -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)