Commit db24e480 authored by Ben Gamari's avatar Ben Gamari 🐢 Committed by Marge Bot

llvmGen: Don't trash STG registers

Fixes #13904.
parent a661df91
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment