Add '-freg-liveness' flag to control if STG liveness information

is used for optimisation. (enabled by default)

5 files changed, 48 insertions, 17 deletions

diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index f239ee50cf..00f4292f63 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -37,7 +37,7 @@ llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
 llvmCodeGen dflags h us cmms
   = let cmm = concat cmms
         (cdata,env) = {-# SCC "llvm_split" #-}
-                      foldr split ([],initLlvmEnv (targetPlatform dflags)) cmm
+                      foldr split ([], initLlvmEnv dflags) cmm
         split (CmmData s d' ) (d,e) = ((s,d'):d,e)
         split (CmmProc i l _) (d,e) =
             let lbl = strCLabel_llvm env $ case i of
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index a896cdd482..9bdb115505 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -13,7 +13,7 @@ module LlvmCodeGen.Base (
 
         LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
         funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform,
-        ghcInternalFunctions,
+        getDflags, ghcInternalFunctions,
 
         cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
         llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
@@ -32,6 +32,7 @@ import CLabel
 import CgUtils ( activeStgRegs )
 import Config
 import Constants
+import DynFlags
 import FastString
 import OldCmm
 import qualified Outputable as Outp
@@ -150,12 +151,13 @@ defaultLlvmVersion = 28
 --
 
 -- two maps, one for functions and one for local vars.
-newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, Platform)
+newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags)
+
 type LlvmEnvMap = UniqFM LlvmType
 
 -- | Get initial Llvm environment.
-initLlvmEnv :: Platform -> LlvmEnv
-initLlvmEnv platform = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, platform)
+initLlvmEnv :: DynFlags -> LlvmEnv
+initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags)
     where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions ]
 
 -- | Here we pre-initialise some functions that are used internally by GHC
@@ -211,7 +213,11 @@ setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p)
 
 -- | Get the platform we are generating code for
 getLlvmPlatform :: LlvmEnv -> Platform
-getLlvmPlatform (LlvmEnv (_, _, _, p)) = p
+getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d
+
+-- | Get the DynFlags for this compilation pass
+getDflags :: LlvmEnv -> DynFlags
+getDflags (LlvmEnv (_, _, _, d)) = d
 
 -- ----------------------------------------------------------------------------
 -- * Label handling
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index ee4a29b64a..d5037828c7 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -16,13 +16,14 @@ import CgUtils ( activeStgRegs, callerSaves )
 import CLabel
 import OldCmm
 import qualified OldPprCmm as PprCmm
-import OrdList
 
+import DynFlags
 import FastString
 import ForeignCall
 import Outputable hiding ( panic, pprPanic )
 import qualified Outputable
 import Platform
+import OrdList
 import UniqSupply
 import Unique
 import Util
@@ -475,7 +476,7 @@ genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData
 -- Call to known function
 genJump env (CmmLit (CmmLabel lbl)) live = do
     (env', vf, stmts, top) <- getHsFunc env lbl
-    (stgRegs, stgStmts) <- funEpilogue live
+    (stgRegs, stgStmts) <- funEpilogue env live
     let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
     let s2  = Return Nothing
     return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
@@ -494,7 +495,7 @@ genJump env expr live = do
                      ++ show (ty) ++ ")"
 
     (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
-    (stgRegs, stgStmts) <- funEpilogue live
+    (stgRegs, stgStmts) <- funEpilogue env live
     let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
     let s3 = Return Nothing
     return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
@@ -1200,29 +1201,33 @@ funPrologue = concat $ map getReg activeStgRegs
 
 
 -- | Function epilogue. Load STG variables to use as argument for call.
-funEpilogue :: Maybe [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements)
-funEpilogue Nothing = do
+-- STG Liveness optimisation done here.
+funEpilogue :: LlvmEnv -> Maybe [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements)
+
+-- Have information and liveness optimisation is enabled
+funEpilogue env (Just live) | dopt Opt_RegLiveness (getDflags env) = do
     loads <- mapM loadExpr activeStgRegs
     let (vars, stmts) = unzip loads
     return (vars, concatOL stmts)
   where
-    loadExpr r = do
+    loadExpr r | r `elem` alwaysLive || r `elem` live = do
         let reg  = lmGlobalRegVar r
         (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
         return (v, unitOL s)
+    loadExpr r = do
+        let ty = (pLower . getVarType $ lmGlobalRegVar r)
+        return (LMLitVar $ LMUndefLit ty, unitOL Nop)
 
-funEpilogue (Just live) = do
+-- don't do liveness optimisation
+funEpilogue _ _ = do
     loads <- mapM loadExpr activeStgRegs
     let (vars, stmts) = unzip loads
     return (vars, concatOL stmts)
   where
-    loadExpr r | r `elem` alwaysLive || r `elem` live = do
+    loadExpr r = do
         let reg  = lmGlobalRegVar r
         (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
         return (v, unitOL s)
-    loadExpr r = do
-        let ty = (pLower . getVarType $ lmGlobalRegVar r)
-        return (LMLitVar $ LMUndefLit ty, unitOL Nop)
 
 
 -- | A serries of statements to trash all the STG registers.
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 47134bb7de..fb2e4e58e7 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -251,6 +251,7 @@ data DynFlag
    | Opt_RegsIterative                  -- do iterative coalescing graph coloring register allocation
    | Opt_PedanticBottoms                -- Be picky about how we treat bottom
    | Opt_LlvmTBAA                       -- Use LLVM TBAA infastructure for improving AA
+   | Opt_RegLiveness                    -- Use the STG Reg liveness information
 
    -- Interface files
    | Opt_IgnoreInterfacePragmas
@@ -1825,6 +1826,7 @@ fFlags = [
   ( "regs-graph",                       Opt_RegsGraph, nop ),
   ( "regs-iterative",                   Opt_RegsIterative, nop ),
   ( "llvm-tbaa",                        Opt_LlvmTBAA, nop),
+  ( "reg-liveness",                     Opt_RegLiveness, nop),
   ( "gen-manifest",                     Opt_GenManifest, nop ),
   ( "embed-manifest",                   Opt_EmbedManifest, nop ),
   ( "ext-core",                         Opt_EmitExternalCore, nop ),
@@ -2074,6 +2076,7 @@ optLevelFlags
     , ([2],     Opt_SpecConstr)
     , ([2],     Opt_RegsGraph)
     , ([0,1,2], Opt_LlvmTBAA)
+    , ([0,1,2], Opt_RegLiveness)
 
 --     , ([2],     Opt_StaticArgumentTransformation)
 -- Max writes: I think it's probably best not to enable SAT with -O2 for the
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index 10679576ef..8e599c26ae 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -1608,6 +1608,23 @@
           </row>
 
           <row>
+            <entry><option>-freg-liveness</option></entry>
+            <entry>Track STG register liveness to avoid saving and restoring
+              dead registers, as well as freeing the dead ones for use in
+              intermediate code. (LLVM backend only).
+              
+              Traditionally GHC has reserved a set of machine registers for the
+              exclusive use of storing a stack pointer, heap pointer and
+              general purpose function argument registers (these are the so
+              called STG registers). This optimisation tracks the liveness of
+              the machine registers the STG registers are mapped to so that the
+              machine register can be used for other purposes when the STG
+              register are dead.</entry>
+            <entry>dynamic</entry>
+            <entry><option>-fno-reg-liveness</option></entry>
+          </row>
+
+          <row>
             <entry><option>-fsimplifier-phases</option></entry>
             <entry>Set the number of phases for the simplifier (default 2).
               Ignored with <option>-O0</option>.</entry>