[commit: ghc] wip/kavon-llvm-improve: fix for #13904: LLVM trashing caller-save global vars (f67c3bc)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/kavon-llvm-improve
Link       : http://ghc.haskell.org/trac/ghc/changeset/f67c3bc3e53a507f5c645859680ea772afb3076b/ghc

>---------------------------------------------------------------

commit f67c3bc3e53a507f5c645859680ea772afb3076b
Author: Kavon Farvardin <kavon at farvard.in>
Date:   Fri Jun 30 16:14:25 2017 +0100

    fix for #13904: LLVM trashing caller-save global vars


>---------------------------------------------------------------

f67c3bc3e53a507f5c645859680ea772afb3076b
 compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 40 ++-------------------------------
 1 file changed, 2 insertions(+), 38 deletions(-)

diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 8179162..3a56b33 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -14,7 +14,7 @@ import LlvmCodeGen.Base
 import LlvmCodeGen.Regs
 
 import BlockId
-import CodeGen.Platform ( activeStgRegs, callerSaves )
+import CodeGen.Platform ( activeStgRegs )
 import CLabel
 import Cmm
 import PprCmm
@@ -211,7 +211,6 @@ genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args
     fptr    <- liftExprData $ getFunPtr funTy t
     argVars' <- castVarsW Signed $ zip argVars argTy
 
-    doTrashStmts
     let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1]
     statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
   | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt)
@@ -294,7 +293,6 @@ genCall t@(PrimTarget op) [] args
     fptr          <- getFunPtrW funTy t
     argVars' <- castVarsW Signed $ zip argVars argTy
 
-    doTrashStmts
     let alignVal = mkIntLit i32 align
         arguments = argVars' ++ (alignVal:isVolVal)
     statement $ Expr $ Call StdCall fptr arguments []
@@ -449,7 +447,6 @@ genCall target res args = runStmtsDecls $ do
                  | never_returns     = statement $ Unreachable
                  | otherwise         = return ()
 
-    doTrashStmts
 
     -- make the actual call
     case retTy of
@@ -1786,12 +1783,9 @@ genLit _ CmmHighStackMark
 funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData
 funPrologue live cmmBlocks = do
 
-  trash <- getTrashRegs
   let getAssignedRegs :: CmmNode O O -> [CmmReg]
       getAssignedRegs (CmmAssign reg _)  = [reg]
-      -- Calls will trash all registers. Unfortunately, this needs them to
-      -- be stack-allocated in the first place.
-      getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs
+      getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmLocal rs
       getAssignedRegs _                  = []
       getRegsBlock (_, body, _)          = concatMap getAssignedRegs $ blockToList body
       assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks
@@ -1848,31 +1842,6 @@ funEpilogue live = do
     let (vars, stmts) = unzip loads
     return (catMaybes vars, concatOL stmts)
 
-
--- | A series of statements to trash all the STG registers.
---
--- In LLVM we pass the STG registers around everywhere in function calls.
--- So this means LLVM considers them live across the entire function, when
--- in reality they usually aren't. For Caller save registers across C calls
--- the saving and restoring of them is done by the Cmm code generator,
--- using Cmm local vars. So to stop LLVM saving them as well (and saving
--- all of them since it thinks they're always live, we trash them just
--- before the call by assigning the 'undef' value to them. The ones we
--- need are restored from the Cmm local var and the ones we don't need
--- are fine to be trashed.
-getTrashStmts :: LlvmM LlvmStatements
-getTrashStmts = do
-  regs <- getTrashRegs
-  stmts <- flip mapM regs $ \ r -> do
-    reg <- getCmmReg (CmmGlobal r)
-    let ty = (pLower . getVarType) reg
-    return $ Store (LMLitVar $ LMUndefLit ty) reg
-  return $ toOL stmts
-
-getTrashRegs :: LlvmM [GlobalReg]
-getTrashRegs = do plat <- getLlvmPlatform
-                  return $ filter (callerSaves plat) (activeStgRegs plat)
-
 -- | Get a function pointer to the CLabel specified.
 --
 -- This is for Haskell functions, function type is assumed, so doesn't work
@@ -1994,11 +1963,6 @@ getCmmRegW = lift . getCmmReg
 genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar
 genLoadW atomic e ty = liftExprData $ genLoad atomic e ty
 
-doTrashStmts :: WriterT LlvmAccum LlvmM ()
-doTrashStmts = do
-    stmts <- lift getTrashStmts
-    tell $ LlvmAccum stmts mempty
-
 -- | Return element of single-element list; 'panic' if list is not a single-element list
 singletonPanic :: String -> [a] -> a
 singletonPanic _ [x] = x