Commit 90e98549 authored by Ben Gamari's avatar Ben Gamari 🐢

llvmGen: Fix #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.

This folds together 2e23e1c7 and
73273be4 previously from @kavon.

Metric Increase:
    T12707
    ManyConstructors
parent 34cf0394
Pipeline #14467 passed with stages
in 423 minutes and 19 seconds
...@@ -28,7 +28,7 @@ module LlvmCodeGen.Base ( ...@@ -28,7 +28,7 @@ module LlvmCodeGen.Base (
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits, tysToParams, llvmFunSection, llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR,
strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
getGlobalPtr, generateExternDecls, getGlobalPtr, generateExternDecls,
...@@ -49,6 +49,7 @@ import GHC.Platform.Regs ( activeStgRegs ) ...@@ -49,6 +49,7 @@ import GHC.Platform.Regs ( activeStgRegs )
import DynFlags import DynFlags
import FastString import FastString
import Cmm hiding ( succ ) import Cmm hiding ( succ )
import CmmUtils ( regsOverlap )
import Outputable as Outp import Outputable as Outp
import GHC.Platform import GHC.Platform
import UniqFM import UniqFM
...@@ -62,7 +63,7 @@ import qualified Stream ...@@ -62,7 +63,7 @@ import qualified Stream
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Control.Monad (ap) import Control.Monad (ap)
import Data.Char (isDigit) import Data.Char (isDigit)
import Data.List (intercalate) import Data.List (sort, groupBy, intercalate)
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
...@@ -152,16 +153,109 @@ llvmFunSection dflags lbl ...@@ -152,16 +153,109 @@ llvmFunSection dflags lbl
-- | A Function's arguments -- | A Function's arguments
llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar] llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs dflags live = llvmFunArgs dflags live =
map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform)) map (lmGlobalRegArg dflags) (filter isPassed allRegs)
where platform = targetPlatform dflags where platform = targetPlatform dflags
isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live allRegs = activeStgRegs platform
isPassed r = not (isSSE r) || isLive r paddedLive = map (\(_,r) -> r) $ padLiveArgs dflags live
isSSE (FloatReg _) = True isLive r = r `elem` alwaysLive || r `elem` paddedLive
isSSE (DoubleReg _) = True isPassed r = not (isFPR r) || isLive r
isSSE (XmmReg _) = True
isSSE (YmmReg _) = True
isSSE (ZmmReg _) = True isFPR :: GlobalReg -> Bool
isSSE _ = False isFPR (FloatReg _) = True
isFPR (DoubleReg _) = True
isFPR (XmmReg _) = True
isFPR (YmmReg _) = True
isFPR (ZmmReg _) = True
isFPR _ = False
sameFPRClass :: GlobalReg -> GlobalReg -> Bool
sameFPRClass (FloatReg _) (FloatReg _) = True
sameFPRClass (DoubleReg _) (DoubleReg _) = True
sameFPRClass (XmmReg _) (XmmReg _) = True
sameFPRClass (YmmReg _) (YmmReg _) = True
sameFPRClass (ZmmReg _) (ZmmReg _) = True
sameFPRClass _ _ = False
normalizeFPRNum :: GlobalReg -> GlobalReg
normalizeFPRNum (FloatReg _) = FloatReg 1
normalizeFPRNum (DoubleReg _) = DoubleReg 1
normalizeFPRNum (XmmReg _) = XmmReg 1
normalizeFPRNum (YmmReg _) = YmmReg 1
normalizeFPRNum (ZmmReg _) = ZmmReg 1
normalizeFPRNum _ = error "normalizeFPRNum expected only FPR regs"
getFPRCtor :: GlobalReg -> Int -> GlobalReg
getFPRCtor (FloatReg _) = FloatReg
getFPRCtor (DoubleReg _) = DoubleReg
getFPRCtor (XmmReg _) = XmmReg
getFPRCtor (YmmReg _) = YmmReg
getFPRCtor (ZmmReg _) = ZmmReg
getFPRCtor _ = error "getFPRCtor expected only FPR regs"
fprRegNum :: GlobalReg -> Int
fprRegNum (FloatReg i) = i
fprRegNum (DoubleReg i) = i
fprRegNum (XmmReg i) = i
fprRegNum (YmmReg i) = i
fprRegNum (ZmmReg i) = i
fprRegNum _ = error "fprRegNum expected only FPR regs"
-- | Input: dynflags, and the list of live registers
--
-- Output: An augmented list of live registers, where padding was
-- added to the list of registers to ensure the calling convention is
-- correctly used by LLVM.
--
-- Each global reg in the returned list is tagged with a bool, which
-- indicates whether the global reg was added as padding, or was an original
-- live register.
--
-- That is, True => padding, False => a real, live global register.
--
-- Also, the returned list is not sorted in any particular order.
--
padLiveArgs :: DynFlags -> LiveGlobalRegs -> [(Bool, GlobalReg)]
padLiveArgs dflags live =
if platformUnregisterised plat
then taggedLive -- not using GHC's register convention for platform.
else padding ++ taggedLive
where
taggedLive = map (\x -> (False, x)) live
plat = targetPlatform dflags
fprLive = filter isFPR live
padding = concatMap calcPad $ groupBy sharesClass fprLive
sharesClass :: GlobalReg -> GlobalReg -> Bool
sharesClass a b = sameFPRClass a b || overlappingClass
where
overlappingClass = regsOverlap dflags (norm a) (norm b)
norm = CmmGlobal . normalizeFPRNum
calcPad :: [GlobalReg] -> [(Bool, GlobalReg)]
calcPad rs = getFPRPadding (getFPRCtor $ head rs) rs
getFPRPadding :: (Int -> GlobalReg) -> LiveGlobalRegs -> [(Bool, GlobalReg)]
getFPRPadding paddingCtor live = padding
where
fprRegNums = sort $ map fprRegNum live
(_, padding) = foldl assignSlots (1, []) $ fprRegNums
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, paddingCtor i))
-- | Llvm standard fun attributes -- | Llvm standard fun attributes
llvmStdFunAttrs :: [LlvmFuncAttr] llvmStdFunAttrs :: [LlvmFuncAttr]
......
...@@ -1841,19 +1841,14 @@ funPrologue live cmmBlocks = do ...@@ -1841,19 +1841,14 @@ funPrologue live cmmBlocks = do
-- STG Liveness optimisation done here. -- STG Liveness optimisation done here.
funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
funEpilogue live = do funEpilogue live = do
dflags <- getDynFlags
-- Have information and liveness optimisation is enabled? -- the bool indicates whether the register is padding.
let liveRegs = alwaysLive ++ live let alwaysNeeded = map (\r -> (False, r)) alwaysLive
isSSE (FloatReg _) = True livePadded = alwaysNeeded ++ padLiveArgs dflags live
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 -- Set to value or "undef" depending on whether the register is
-- actually live -- actually live
dflags <- getDynFlags
let loadExpr r = do let loadExpr r = do
(v, _, s) <- getCmmRegVal (CmmGlobal r) (v, _, s) <- getCmmRegVal (CmmGlobal r)
return (Just $ v, s) return (Just $ v, s)
...@@ -1861,9 +1856,12 @@ funEpilogue live = do ...@@ -1861,9 +1856,12 @@ funEpilogue live = do
let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
return (Just $ LMLitVar $ LMUndefLit ty, nilOL) return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
platform <- getDynFlag targetPlatform platform <- getDynFlag targetPlatform
loads <- flip mapM (activeStgRegs platform) $ \r -> case () of let allRegs = activeStgRegs platform
_ | r `elem` liveRegs -> loadExpr r loads <- flip mapM allRegs $ \r -> case () of
| not (isSSE r) -> loadUndef r _ | (False, r) `elem` livePadded
-> loadExpr r -- if r is not padding, load it
| not (isFPR r) || (True, r) `elem` livePadded
-> loadUndef r
| otherwise -> return (Nothing, nilOL) | otherwise -> return (Nothing, nilOL)
let (vars, stmts) = unzip loads let (vars, stmts) = unzip loads
......
...@@ -185,8 +185,7 @@ test('T13825-unit', ...@@ -185,8 +185,7 @@ test('T13825-unit',
test('T14619', normal, compile_and_run, ['']) test('T14619', normal, compile_and_run, [''])
test('T14754', normal, compile_and_run, ['']) test('T14754', normal, compile_and_run, [''])
test('T14346', only_ways(['threaded1','threaded2']), compile_and_run, ['-O -threaded']) test('T14346', only_ways(['threaded1','threaded2']), compile_and_run, ['-O -threaded'])
test('T14251', [expect_broken_for(14251, ['optllvm'])], test('T14251', normal, compile_and_run, [''])
compile_and_run, [''])
# These actually used to fail with all optimisation settings, but adding -O just # These actually used to fail with all optimisation settings, but adding -O just
# to make sure # to make sure
......
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