summaryrefslogtreecommitdiff
path: root/compiler/GHC/CmmToAsm/Reg
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/CmmToAsm/Reg')
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph.hs8
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs4
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs13
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear.hs16
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs11
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs3
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Liveness.hs45
7 files changed, 67 insertions, 33 deletions
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph.hs b/compiler/GHC/CmmToAsm/Reg/Graph.hs
index c544d9ff8a..f31e84a5ff 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Graph.hs
@@ -17,6 +17,7 @@ import GHC.CmmToAsm.Reg.Graph.TrivColorable
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Reg.Target
import GHC.CmmToAsm.Config
+import GHC.CmmToAsm.Types
import GHC.Platform.Reg.Class
import GHC.Platform.Reg
@@ -45,7 +46,7 @@ maxSpinCount = 10
-- | The top level of the graph coloring register allocator.
regAlloc
- :: (Outputable statics, Outputable instr, Instruction instr)
+ :: (Outputable statics, Instruction instr)
=> NCGConfig
-> UniqFM RegClass (UniqSet RealReg) -- ^ registers we can use for allocation
-> UniqSet Int -- ^ set of available spill slots.
@@ -90,7 +91,6 @@ regAlloc config regsFree slotsFree slotsCount code cfg
regAlloc_spin
:: forall instr statics.
(Instruction instr,
- Outputable instr,
Outputable statics)
=> NCGConfig
-> Int -- ^ Number of solver iterations we've already performed.
@@ -388,7 +388,7 @@ graphAddCoalesce (r1, r2) graph
-- | Patch registers in code using the reg -> reg mapping in this graph.
patchRegsFromGraph
- :: (Outputable statics, Outputable instr, Instruction instr)
+ :: (Outputable statics, Instruction instr)
=> Platform -> Color.Graph VirtualReg RegClass RealReg
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
@@ -413,7 +413,7 @@ patchRegsFromGraph platform graph code
= pprPanic "patchRegsFromGraph: register mapping failed."
( text "There is no node in the graph for register "
<> ppr reg
- $$ ppr code
+ $$ pprLiveCmmDecl platform code
$$ Color.dotGraph
(\_ -> text "white")
(trivColorable platform
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
index a5d09d5eea..872b01c11a 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
@@ -76,7 +76,7 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2)
-- For each vreg, the number of times it was written to, read from,
-- and the number of instructions it was live on entry to (lifetime)
--
-slurpSpillCostInfo :: forall instr statics. (Outputable instr, Instruction instr)
+slurpSpillCostInfo :: forall instr statics. Instruction instr
=> Platform
-> Maybe CFG
-> LiveCmmDecl statics instr
@@ -116,7 +116,7 @@ slurpSpillCostInfo platform cfg cmm
| otherwise
= pprPanic "RegSpillCost.slurpSpillCostInfo"
- $ text "no liveness information on instruction " <> ppr instr
+ $ text "no liveness information on instruction " <> pprInstr platform instr
countLIs scale rsLiveEntry (LiveInstr instr (Just live) : lis)
= do
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
index a0b1519a93..4e325e8778 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, CPP #-}
+{-# LANGUAGE BangPatterns, CPP, DeriveFunctor #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -23,15 +23,17 @@ import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Reg.Graph.Spill
import GHC.CmmToAsm.Reg.Graph.SpillCost
import GHC.CmmToAsm.Reg.Graph.TrivColorable
-import GHC.CmmToAsm.Instr
-import GHC.Platform.Reg.Class
-import GHC.Platform.Reg
import GHC.CmmToAsm.Reg.Target
+import GHC.CmmToAsm.Instr
+import GHC.CmmToAsm.Types
+
import GHC.Platform
+import GHC.Platform.Reg
+import GHC.Platform.Reg.Class
-import GHC.Utils.Outputable
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
+import GHC.Utils.Outputable
import GHC.Utils.Monad.State
-- | Holds interesting statistics from the register allocator.
@@ -108,6 +110,7 @@ data RegAllocStats statics instr
-- | Target platform
, raPlatform :: !Platform
}
+ deriving (Functor)
instance (Outputable statics, Outputable instr)
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs
index 4d666bc557..8d4da4bd2e 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs
@@ -122,6 +122,7 @@ import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Reg.Utils
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Config
+import GHC.CmmToAsm.Types
import GHC.Platform.Reg
import GHC.Cmm.BlockId
@@ -147,7 +148,7 @@ import Control.Applicative
-- Allocate registers
regAlloc
- :: (Outputable instr, Instruction instr)
+ :: Instruction instr
=> NCGConfig
-> LiveCmmDecl statics instr
-> UniqSM ( NatCmmDecl statics instr
@@ -204,7 +205,7 @@ regAlloc _ (CmmProc _ _ _ _)
-- an entry in the block map or it is the first block.
--
linearRegAlloc
- :: (Outputable instr, Instruction instr)
+ :: Instruction instr
=> NCGConfig
-> [BlockId] -- ^ entry points
-> BlockMap RegSet
@@ -236,7 +237,7 @@ linearRegAlloc config entry_ids block_live sccs
-- | Constraints on the instruction instances used by the
-- linear allocator.
type OutputableRegConstraint freeRegs instr =
- (FR freeRegs, Outputable freeRegs, Outputable instr, Instruction instr)
+ (FR freeRegs, Outputable freeRegs, Instruction instr)
linearRegAlloc'
:: OutputableRegConstraint freeRegs instr
@@ -468,7 +469,10 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
-- See Note [Unique Determinism and code generation]
raInsn _ _ _ instr
- = pprPanic "raInsn" (text "no match for:" <> ppr instr)
+ = do
+ platform <- getPlatform
+ let instr' = fmap (pprInstr platform) instr
+ pprPanic "raInsn" (text "no match for:" <> ppr instr')
-- ToDo: what can we do about
--
@@ -764,7 +768,7 @@ data SpillLoc = ReadMem StackSlot -- reading from register only in memory
-- the list of free registers and free stack slots.
allocateRegsAndSpill
- :: forall freeRegs instr. (FR freeRegs, Outputable instr, Instruction instr)
+ :: forall freeRegs instr. (FR freeRegs, Instruction instr)
=> Bool -- True <=> reading (load up spilled regs)
-> [VirtualReg] -- don't push these out
-> [instr] -- spill insns
@@ -830,7 +834,7 @@ findPrefRealReg vreg = do
-- reading is redundant with reason, but we keep it around because it's
-- convenient and it maintains the recursive structure of the allocator. -- EZY
-allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)
+allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr)
=> Bool
-> [VirtualReg]
-> [instr]
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
index de489b342b..d0330a4f6a 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
@@ -18,12 +18,13 @@ import GHC.CmmToAsm.Reg.Linear.FreeRegs
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Config
+import GHC.CmmToAsm.Types
+
import GHC.Platform.Reg
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
import GHC.Data.Graph.Directed
-import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.Unique
import GHC.Types.Unique.FM
@@ -33,7 +34,7 @@ import GHC.Types.Unique.Set
-- vregs are in the correct regs for its destination.
--
joinToTargets
- :: (FR freeRegs, Instruction instr, Outputable instr)
+ :: (FR freeRegs, Instruction instr)
=> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs
-- that are known to be live on the entry to each block.
@@ -57,7 +58,7 @@ joinToTargets block_live id instr
-----
joinToTargets'
- :: (FR freeRegs, Instruction instr, Outputable instr)
+ :: (FR freeRegs, Instruction instr)
=> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs
-- that are known to be live on the entry to each block.
@@ -111,7 +112,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests)
-- this is the first time we jumped to this block.
-joinToTargets_first :: (FR freeRegs, Instruction instr, Outputable instr)
+joinToTargets_first :: (FR freeRegs, Instruction instr)
=> BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
@@ -140,7 +141,7 @@ joinToTargets_first block_live new_blocks block_id instr dest dests
-- we've jumped to this block before
-joinToTargets_again :: (Instruction instr, FR freeRegs, Outputable instr)
+joinToTargets_again :: (Instruction instr, FR freeRegs)
=> BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs
index 6411e5285d..4d44b43492 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs
@@ -12,10 +12,11 @@ import GHC.CmmToAsm.Reg.Linear.Base
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Instr
import GHC.Types.Unique (Unique)
+import GHC.CmmToAsm.Types
import GHC.Types.Unique.FM
-import GHC.Utils.Outputable
+import GHC.Utils.Outputable
import GHC.Utils.Monad.State
-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
index 00adf1cc34..09db54fa76 100644
--- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -26,6 +27,7 @@ module GHC.CmmToAsm.Reg.Liveness (
mapBlockTop, mapBlockTopM, mapSCCM,
mapGenBlockTop, mapGenBlockTopM,
+ mapLiveCmmDecl, pprLiveCmmDecl,
stripLive,
stripLiveBlock,
slurpConflicts,
@@ -43,6 +45,8 @@ import GHC.Platform.Reg
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Config
+import GHC.CmmToAsm.Types
+import GHC.CmmToAsm.Utils
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
@@ -106,6 +110,8 @@ data InstrSR instr
-- | reload this reg from a stack slot
| RELOAD Int Reg
+ deriving (Functor)
+
instance Instruction instr => Instruction (InstrSR instr) where
regUsageOfInstr platform i
= case i of
@@ -163,10 +169,13 @@ instance Instruction instr => Instruction (InstrSR instr) where
mkStackDeallocInstr platform amount =
Instr <$> mkStackDeallocInstr platform amount
+ pprInstr platform i = ppr (fmap (pprInstr platform) i)
+
-- | An instruction with liveness information.
data LiveInstr instr
= LiveInstr (InstrSR instr) (Maybe Liveness)
+ deriving (Functor)
-- | Liveness information.
-- The regs which die are ones which are no longer live in the *next* instruction
@@ -494,7 +503,7 @@ slurpReloadCoalesce live
-- | Strip away liveness information, yielding NatCmmDecl
stripLive
- :: (Outputable statics, Outputable instr, Instruction instr)
+ :: (Outputable statics, Instruction instr)
=> NCGConfig
-> LiveCmmDecl statics instr
-> NatCmmDecl statics instr
@@ -502,7 +511,7 @@ stripLive
stripLive config live
= stripCmm live
- where stripCmm :: (Outputable statics, Outputable instr, Instruction instr)
+ where stripCmm :: (Outputable statics, Instruction instr)
=> LiveCmmDecl statics instr -> NatCmmDecl statics instr
stripCmm (CmmData sec ds) = CmmData sec ds
stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs)
@@ -519,7 +528,21 @@ stripLive config live
-- If the proc has blocks but we don't know what the first one was, then we're dead.
stripCmm proc
- = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
+ = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprLiveCmmDecl (ncgPlatform config) proc)
+
+
+-- | Pretty-print a `LiveCmmDecl`
+pprLiveCmmDecl :: (Outputable statics, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SDoc
+pprLiveCmmDecl platform d = ppr (mapLiveCmmDecl (pprInstr platform) d)
+
+
+-- | Map over instruction type in `LiveCmmDecl`
+mapLiveCmmDecl
+ :: Outputable statics
+ => (instr -> b)
+ -> LiveCmmDecl statics instr
+ -> LiveCmmDecl statics b
+mapLiveCmmDecl f proc = fmap (fmap (fmap (fmap (fmap f)))) proc
-- | Strip away liveness information from a basic block,
-- and make real spill instructions out of SPILL, RELOAD pseudos along the way.
@@ -653,15 +676,16 @@ patchRegsLiveInstr patchF li
-- | Convert a NatCmmDecl to a LiveCmmDecl, with liveness information
cmmTopLiveness
- :: (Outputable instr, Instruction instr)
- => Maybe CFG -> Platform
+ :: Instruction instr
+ => Maybe CFG
+ -> Platform
-> NatCmmDecl statics instr
-> UniqSM (LiveCmmDecl statics instr)
cmmTopLiveness cfg platform cmm
= regLiveness platform $ natCmmTopToLive cfg cmm
natCmmTopToLive
- :: (Instruction instr, Outputable instr)
+ :: Instruction instr
=> Maybe CFG -> NatCmmDecl statics instr
-> LiveCmmDecl statics instr
@@ -747,7 +771,7 @@ sccBlocks blocks entries mcfg = map (fmap node_payload) sccs
--
regLiveness
- :: (Outputable instr, Instruction instr)
+ :: Instruction instr
=> Platform
-> LiveCmmDecl statics instr
-> UniqSM (LiveCmmDecl statics instr)
@@ -830,7 +854,7 @@ reverseBlocksInTops top
-- want for the next pass.
--
computeLiveness
- :: (Outputable instr, Instruction instr)
+ :: Instruction instr
=> Platform
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers
@@ -841,10 +865,11 @@ computeLiveness
computeLiveness platform sccs
= case checkIsReverseDependent sccs of
Nothing -> livenessSCCs platform mapEmpty [] sccs
- Just bad -> pprPanic "RegAlloc.Liveness.computeLiveness"
+ Just bad -> let sccs' = fmap (fmap (fmap (fmap (pprInstr platform)))) sccs
+ in pprPanic "RegAlloc.Liveness.computeLiveness"
(vcat [ text "SCCs aren't in reverse dependent order"
, text "bad blockId" <+> ppr bad
- , ppr sccs])
+ , ppr sccs'])
livenessSCCs
:: Instruction instr
View Lorry Controller Status