diff options
author | Ben Gamari <ben@smart-cactus.org> | 2020-01-06 12:27:38 -0500 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-01-20 15:32:52 -0500 |
commit | db24e4803fe9fb13b85fc83193ff4afc407702f6 (patch) | |
tree | 9651f87af9d6aa2d89d207599a42ce6108873e1b | |
parent | a661df91da5d867ab3e6a912e03a9e1756e59cb6 (diff) | |
download | haskell-db24e4803fe9fb13b85fc83193ff4afc407702f6.tar.gz |
llvmGen: Don't trash STG registers
Fixes #13904.
-rw-r--r-- | compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 40 |
1 files changed, 2 insertions, 38 deletions
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index c01e575546..7a6e3386ae 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 GHC.Platform.Regs ( activeStgRegs, callerSaves ) +import GHC.Platform.Regs ( activeStgRegs ) import CLabel import Cmm import PprCmm @@ -222,7 +222,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) @@ -307,7 +306,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 [] @@ -462,7 +460,6 @@ genCall target res args = runStmtsDecls $ do | never_returns = statement $ Unreachable | otherwise = return () - doTrashStmts -- make the actual call case retTy of @@ -1810,12 +1807,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 @@ -1875,31 +1869,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 @@ -2021,11 +1990,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 |