revert-llvm-fixes 10.2 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249
commit 377fe39888b1c711d15c94583ec83680d8ae7bf4
Author: Ben Gamari <ben@smart-cactus.org>
Date:   Tue Oct 30 11:12:46 2018 -0400

    Revert "Multiple fixes / improvements for LLVM backend"

    This reverts commit 73273be476a8cc6c13368660b042b3b0614fd928.

    Unfortunately we were unable to come to a fix that didn't sacrifice the
    ability to bootstrap GHC using the LLVM backend. Reverting for 8.6.2.

Index: b/compiler/llvmGen/Llvm/Types.hs
===================================================================
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -560,7 +560,7 @@ instance Outputable LlvmFuncAttr where
   ppr OptSize            = text "optsize"
   ppr NoReturn           = text "noreturn"
   ppr NoUnwind           = text "nounwind"
-  ppr ReadNone           = text "readnone"
+  ppr ReadNone           = text "readnon"
   ppr ReadOnly           = text "readonly"
   ppr Ssp                = text "ssp"
   ppr SspReq             = text "ssqreq"
Index: b/compiler/llvmGen/LlvmCodeGen/Base.hs
===================================================================
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -26,7 +26,7 @@ module LlvmCodeGen.Base (
 
         cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
         llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
-        llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isSSE,
+        llvmPtrBits, tysToParams, llvmFunSection,
 
         strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
         getGlobalPtr, generateExternDecls,
@@ -58,8 +58,6 @@ import ErrUtils
 import qualified Stream
 
 import Control.Monad (ap)
-import Data.List (sort)
-import Data.Maybe (mapMaybe)
 
 -- ----------------------------------------------------------------------------
 -- * Some Data Types
@@ -149,58 +147,16 @@ llvmFunSection dflags lbl
 -- | A Function's arguments
 llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
 llvmFunArgs dflags live =
-    map (lmGlobalRegArg dflags) (filter isPassed allRegs)
+    map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform))
     where platform = targetPlatform dflags
-          allRegs = activeStgRegs platform
-          paddedLive = map (\(_,r) -> r) $ padLiveArgs live
-          isLive r = r `elem` alwaysLive || r `elem` paddedLive
+          isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live
           isPassed r = not (isSSE r) || isLive r
-
-
-isSSE :: GlobalReg -> Bool
-isSSE (FloatReg _)  = True
-isSSE (DoubleReg _) = True
-isSSE (XmmReg _)    = True
-isSSE (YmmReg _)    = True
-isSSE (ZmmReg _)    = True
-isSSE _             = False
-
-sseRegNum :: GlobalReg -> Maybe Int
-sseRegNum (FloatReg i)  = Just i
-sseRegNum (DoubleReg i) = Just i
-sseRegNum (XmmReg i)    = Just i
-sseRegNum (YmmReg i)    = Just i
-sseRegNum (ZmmReg i)    = Just i
-sseRegNum _             = Nothing
-
--- the bool indicates whether the global reg was added as padding.
--- the returned list is not sorted in any particular order,
--- but does indicate the set of live registers needed, with SSE padding.
-padLiveArgs :: LiveGlobalRegs -> [(Bool, GlobalReg)]
-padLiveArgs live = allRegs
-    where
-        sseRegNums = sort $ mapMaybe sseRegNum live
-        (_, padding) = foldl assignSlots (1, []) $ sseRegNums
-        allRegs = padding ++ map (\r -> (False, r)) live
-
-        assignSlots (i, acc) regNum
-            | i == regNum = -- don't need padding here
-                  (i+1, acc)
-            | i < regNum = let -- add padding for slots i .. regNum-1
-                  numNeeded = regNum-i
-                  acc' = genPad i numNeeded ++ acc
-                in
-                  (regNum+1, acc')
-            | otherwise = error "padLiveArgs -- i > regNum ??"
-
-        genPad start n =
-            take n $ flip map (iterate (+1) start) (\i ->
-                (True, FloatReg i))
-                -- NOTE: Picking float should be fine for the following reasons:
-                -- (1) Float aliases with all the other SSE register types on
-                -- the given platform.
-                -- (2) The argument is not live anyways.
-
+          isSSE (FloatReg _)  = True
+          isSSE (DoubleReg _) = True
+          isSSE (XmmReg _)    = True
+          isSSE (YmmReg _)    = True
+          isSSE (ZmmReg _)    = True
+          isSSE _             = False
 
 -- | Llvm standard fun attributes
 llvmStdFunAttrs :: [LlvmFuncAttr]
Index: b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
===================================================================
--- 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 )
+import CodeGen.Platform ( activeStgRegs, callerSaves )
 import CLabel
 import Cmm
 import PprCmm
@@ -211,6 +211,7 @@ genCall t@(PrimTarget (MO_Prefetch_Data
     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)
@@ -293,6 +294,7 @@ 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 []
@@ -444,6 +446,7 @@ genCall target res args = runStmtsDecls
                  | never_returns     = statement $ Unreachable
                  | otherwise         = return ()
 
+    doTrashStmts
 
     -- make the actual call
     case retTy of
@@ -1756,9 +1759,12 @@ genLit _ CmmHighStackMark
 funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData
 funPrologue live cmmBlocks = do
 
+  trash <- getTrashRegs
   let getAssignedRegs :: CmmNode O O -> [CmmReg]
       getAssignedRegs (CmmAssign reg _)  = [reg]
-      getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmLocal rs
+      -- 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 _                  = []
       getRegsBlock (_, body, _)          = concatMap getAssignedRegs $ blockToList body
       assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks
@@ -1788,9 +1794,14 @@ funPrologue live cmmBlocks = do
 funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
 funEpilogue live = do
 
-    -- the bool indicates whether the register is padding.
-    let alwaysNeeded = map (\r -> (False, r)) alwaysLive
-        livePadded = alwaysNeeded ++ padLiveArgs live
+    -- Have information and liveness optimisation is enabled?
+    let liveRegs = alwaysLive ++ live
+        isSSE (FloatReg _)  = True
+        isSSE (DoubleReg _) = True
+        isSSE (XmmReg _)    = True
+        isSSE (YmmReg _)    = True
+        isSSE (ZmmReg _)    = True
+        isSSE _             = False
 
     -- Set to value or "undef" depending on whether the register is
     -- actually live
@@ -1802,17 +1813,39 @@ funEpilogue live = do
           let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
           return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
     platform <- getDynFlag targetPlatform
-    let allRegs = activeStgRegs platform
-    loads <- flip mapM allRegs $ \r -> case () of
-      _ | (False, r) `elem` livePadded
-                             -> loadExpr r   -- if r is not padding, load it
-        | not (isSSE r) || (True, r) `elem` livePadded
-                             -> loadUndef r
+    loads <- flip mapM (activeStgRegs platform) $ \r -> case () of
+      _ | r `elem` liveRegs  -> loadExpr r
+        | not (isSSE r)      -> loadUndef r
         | otherwise          -> return (Nothing, nilOL)
 
     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
@@ -1934,3 +1967,7 @@ 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
Index: b/compiler/main/DriverPipeline.hs
===================================================================
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1465,7 +1465,7 @@ runPhase (RealPhase LlvmOpt) input_fn df
         -- we always (unless -optlo specified) run Opt since we rely on it to
         -- fix up some pretty big deficiencies in the code we generate
         llvmOpts = case optLevel dflags of
-          0 -> "-mem2reg -globalopt -lower-expect"
+          0 -> "-mem2reg -globalopt"
           1 -> "-O1 -globalopt"
           _ -> "-O2"