From 6e361d895dda4600a85e01c72ff219474b5c7190 Mon Sep 17 00:00:00 2001 From: Kavon Farvardin Date: Thu, 4 Oct 2018 13:44:55 -0400 Subject: [PATCH] Multiple fixes / improvements for LLVM backend - Fix for #13904 -- stop "trashing" callee-saved registers, since it is not actually doing anything useful. - Fix for #14251 -- fixes the calling convention for functions passing raw SSE-register values by adding padding as needed to get the values in the right registers. This problem cropped up when some args were unused an dropped from the live list. - Fixed a typo in 'readnone' attribute - Added 'lower-expect' pass to level 0 LLVM optimization passes to improve block layout in LLVM for stack checks, etc. Test Plan: `make test WAYS=optllvm` and `make test WAYS=llvm` Reviewers: bgamari, simonmar, angerman Reviewed By: angerman Subscribers: rwbarton, carter GHC Trac Issues: #13904, #14251 Differential Revision: https://phabricator.haskell.org/D5190 (cherry picked from commit adcb5fb47c0942671d409b940d8884daa9359ca4) --- compiler/llvmGen/Llvm/Types.hs | 2 +- compiler/llvmGen/LlvmCodeGen/Base.hs | 62 ++++++++++++++++++++---- compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 59 +++++----------------- compiler/main/DriverPipeline.hs | 2 +- testsuite/tests/codeGen/should_run/all.T | 4 +- 5 files changed, 67 insertions(+), 62 deletions(-) diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 87111499fc0..c1c51afcf0f 100644 --- 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 "readnon" + ppr ReadNone = text "readnone" ppr ReadOnly = text "readonly" ppr Ssp = text "ssp" ppr SspReq = text "ssqreq" diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 6e20da48c1b..ec91bacc4c8 100644 --- 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, + llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isSSE, strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, getGlobalPtr, generateExternDecls, @@ -58,6 +58,8 @@ import ErrUtils import qualified Stream import Control.Monad (ap) +import Data.List (sort) +import Data.Maybe (mapMaybe) -- ---------------------------------------------------------------------------- -- * Some Data Types @@ -147,16 +149,58 @@ llvmFunSection dflags lbl -- | A Function's arguments llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar] llvmFunArgs dflags live = - map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform)) + map (lmGlobalRegArg dflags) (filter isPassed allRegs) where platform = targetPlatform dflags - isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live + allRegs = activeStgRegs platform + paddedLive = map (\(_,r) -> r) $ padLiveArgs live + isLive r = r `elem` alwaysLive || r `elem` paddedLive isPassed r = not (isSSE r) || isLive r - isSSE (FloatReg _) = True - isSSE (DoubleReg _) = True - isSSE (XmmReg _) = True - isSSE (YmmReg _) = True - isSSE (ZmmReg _) = True - isSSE _ = False + + +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. + -- | Llvm standard fun attributes llvmStdFunAttrs :: [LlvmFuncAttr] diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index e812dd445f1..a7121b7909a 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 [] @@ -446,7 +444,6 @@ genCall target res args = runStmtsDecls $ do | never_returns = statement $ Unreachable | otherwise = return () - doTrashStmts -- make the actual call case retTy of @@ -1759,12 +1756,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 @@ -1794,14 +1788,9 @@ funPrologue live cmmBlocks = do funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) funEpilogue live = do - -- 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 + -- the bool indicates whether the register is padding. + let alwaysNeeded = map (\r -> (False, r)) alwaysLive + livePadded = alwaysNeeded ++ padLiveArgs live -- Set to value or "undef" depending on whether the register is -- actually live @@ -1813,39 +1802,17 @@ funEpilogue live = do let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) return (Just $ LMLitVar $ LMUndefLit ty, nilOL) platform <- getDynFlag targetPlatform - loads <- flip mapM (activeStgRegs platform) $ \r -> case () of - _ | r `elem` liveRegs -> loadExpr r - | not (isSSE r) -> loadUndef r + 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 | 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 @@ -1967,7 +1934,3 @@ 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 diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 86dd913461c..f4d5e7f553c 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1465,7 +1465,7 @@ runPhase (RealPhase LlvmOpt) input_fn dflags -- 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" + 0 -> "-mem2reg -globalopt -lower-expect" 1 -> "-O1 -globalopt" _ -> "-O2"