summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreas Klebinger <klebinger.andreas@gmx.at>2021-07-19 18:12:44 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-09-30 19:42:54 -0400
commitef92a0095cee1f623fba1c285c1836e80bf16223 (patch)
treeb7a7d9c5b179bbf3cbd28877672ecc70387b1734
parent94f3ce7e4a4e0c952687eef511aa68cc38b1ad0d (diff)
downloadhaskell-ef92a0095cee1f623fba1c285c1836e80bf16223.tar.gz
NCG: Linear-reg-alloc: A few small implemenation tweaks.
Removed an intermediate list via a fold. realRegsAlias: Manually inlined the list functions to get better code. Linear.hs added a bang somewhere.
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear.hs40
-rw-r--r--compiler/GHC/Platform/Reg.hs14
-rw-r--r--compiler/GHC/Types/Unique/FM.hs11
3 files changed, 40 insertions, 25 deletions
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs
index a9a4545f62..021c909a52 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs
@@ -677,29 +677,30 @@ saveClobberedTemps [] _
saveClobberedTemps clobbered dying
= do
assig <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)
- -- Unique represents the VirtualReg
- let to_spill :: [(Unique, RealReg)]
- to_spill
- = [ (temp,reg)
- | (temp, InReg reg) <- nonDetUFMToList assig
- -- This is non-deterministic but we do not
- -- currently support deterministic code-generation.
- -- See Note [Unique Determinism and code generation]
- , any (realRegsAlias reg) clobbered
- , temp `notElem` map getUnique dying ]
-
- (instrs,assig') <- clobber assig [] to_spill
+ (assig',instrs) <- nonDetStrictFoldUFM_DirectlyM maybe_spill (assig,[]) assig
setAssigR assig'
return $ -- mkComment (text "<saveClobberedTemps>") ++
instrs
-- ++ mkComment (text "</saveClobberedTemps>")
where
- -- See Note [UniqFM and the register allocator]
- clobber :: RegMap Loc -> [instr] -> [(Unique,RealReg)] -> RegM freeRegs ([instr], RegMap Loc)
- clobber assig instrs []
- = return (instrs, assig)
+ -- Unique represents the VirtualReg
+ -- Here we separate the cases which we do want to spill from these we don't.
+ maybe_spill :: Unique -> (RegMap Loc,[instr]) -> (Loc) -> RegM freeRegs (RegMap Loc,[instr])
+ maybe_spill !temp !(assig,instrs) !loc =
+ case loc of
+ -- This is non-deterministic but we do not
+ -- currently support deterministic code-generation.
+ -- See Note [Unique Determinism and code generation]
+ InReg reg
+ | any (realRegsAlias reg) clobbered
+ , temp `notElem` map getUnique dying
+ -> clobber temp (assig,instrs) (reg)
+ _ -> return (assig,instrs)
- clobber assig instrs ((temp, reg) : rest)
+
+ -- See Note [UniqFM and the register allocator]
+ clobber :: Unique -> (RegMap Loc,[instr]) -> (RealReg) -> RegM freeRegs (RegMap Loc,[instr])
+ clobber temp (assig,instrs) (reg)
= do platform <- getPlatform
freeRegs <- getFreeRegsR
@@ -718,7 +719,7 @@ saveClobberedTemps clobbered dying
let instr = mkRegRegMoveInstr platform
(RegReal reg) (RegReal my_reg)
- clobber new_assign (instr : instrs) rest
+ return (new_assign,(instr : instrs))
-- (2) no free registers: spill the value
[] -> do
@@ -729,7 +730,8 @@ saveClobberedTemps clobbered dying
let new_assign = addToUFM_Directly assig temp (InBoth reg slot)
- clobber new_assign (spill ++ instrs) rest
+ return (new_assign, (spill ++ instrs))
+
diff --git a/compiler/GHC/Platform/Reg.hs b/compiler/GHC/Platform/Reg.hs
index 5edd39df51..8203b9bbea 100644
--- a/compiler/GHC/Platform/Reg.hs
+++ b/compiler/GHC/Platform/Reg.hs
@@ -34,7 +34,6 @@ import GHC.Utils.Panic
import GHC.Types.Unique
import GHC.Builtin.Uniques
import GHC.Platform.Reg.Class
-import Data.List (intersect)
-- | An identifier for a primitive real machine register.
type RegNo
@@ -173,8 +172,17 @@ regNosOfRealReg rr
realRegsAlias :: RealReg -> RealReg -> Bool
-realRegsAlias rr1 rr2
- = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)
+realRegsAlias rr1 rr2 =
+ -- used to be `not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)`
+ -- but that resulted in some gnarly, gnarly, allocating code. So we manually
+ -- write out all the cases which gives us nice non-allocating code.
+ case rr1 of
+ RealRegSingle r1 ->
+ case rr2 of RealRegPair r2 r3 -> r1 == r2 || r1 == r3
+ RealRegSingle r2 -> r1 == r2
+ RealRegPair r1 r2 ->
+ case rr2 of RealRegPair r3 r4 -> r1 == r3 || r1 == r4 || r2 == r3 || r2 == r4
+ RealRegSingle r3 -> r1 == r3 || r2 == r3
--------------------------------------------------------------------------------
-- | A register, either virtual or real
diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs
index 46b8643f76..a293c6bb10 100644
--- a/compiler/GHC/Types/Unique/FM.hs
+++ b/compiler/GHC/Types/Unique/FM.hs
@@ -63,7 +63,7 @@ module GHC.Types.Unique.FM (
intersectUFM_C,
disjointUFM,
equalKeysUFM,
- nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_Directly,
+ nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_DirectlyM,
anyUFM, allUFM, seqEltsUFM,
mapUFM, mapUFM_Directly,
elemUFM, elemUFM_Directly,
@@ -402,11 +402,16 @@ nonDetKeysUFM (UFM m) = map getUnique $ M.keys m
nonDetStrictFoldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a
nonDetStrictFoldUFM k z (UFM m) = M.foldl' (flip k) z m
+-- | In essence foldM
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce
-- nondeterminism.
-nonDetStrictFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a
-nonDetStrictFoldUFM_Directly k z (UFM m) = M.foldlWithKey' (\z' i x -> k (getUnique i) x z') z m
+{-# INLINE nonDetStrictFoldUFM_DirectlyM #-} -- Allow specialization
+nonDetStrictFoldUFM_DirectlyM :: (Monad m) => (Unique -> b -> elt -> m b) -> b -> UniqFM key elt -> m b
+nonDetStrictFoldUFM_DirectlyM f z0 (UFM xs) = M.foldrWithKey c return xs z0
+ -- See Note [List fusion and continuations in 'c']
+ where c u x k z = f (getUnique u) z x >>= k
+ {-# INLINE c #-}
-- See Note [Deterministic UniqFM] to learn about nondeterminism.
-- If you use this please provide a justification why it doesn't introduce