Refactored linear allocator into separate liveness annotation and allocation stages.
Added graph coloring allocator, use -fregs-graph to enable.
New dump flags are
-ddump-asm-native -- output of cmm -> native transform.
-ddump-asm-liveness -- code annotated with register liveness info
-ddump-asm-coalesce -- output of register move coalescing
(this is a separate pass when using the coloring allocator)
(this could change in the future)
-ddump-asm-regalloc -- code after register allocation
-ddump-asm-regalloc-stages -- blocks after each build/spill stage of coloring allocator
-ddump-asm-conflicts -- a global register liveness graph in graphviz format
The new register allocator will allocate some registers, but it's not
quite ready for prime-time yet. The spill code generator needs some work...
--
module PprCmm (
- writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
+ writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic
) where
#include "HsVersions.h"
instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where
ppr c = pprCmm c
-instance (Outputable info) => Outputable (GenCmmTop CmmStatic info CmmStmt) where
+instance (Outputable d, Outputable info, Outputable i)
+ => Outputable (GenCmmTop d info i) where
ppr t = pprTop t
-instance Outputable CmmBasicBlock where
+instance (Outputable instr) => Outputable (GenBasicBlock instr) where
ppr b = pprBBlock b
+instance Outputable BlockId where
+ ppr id = pprBlockId id
+
instance Outputable CmmStmt where
ppr s = pprStmt s
instance Outputable CmmInfo where
ppr e = pprInfo e
+
+
-----------------------------------------------------------------------------
pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
-- --------------------------------------------------------------------------
-- Top level `procedure' blocks.
--
-pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc
+pprTop :: (Outputable d, Outputable info, Outputable i)
+ => GenCmmTop d info i -> SDoc
+
pprTop (CmmProc info lbl params blocks )
= vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
-- section "data" { ... }
--
pprTop (CmmData section ds) =
- (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
+ (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
$$ rbrace
-- --------------------------------------------------------------------------
-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
-- lbl: stmt ; stmt ; ..
-pprBBlock :: CmmBasicBlock -> SDoc
+pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
pprBBlock (BasicBlock ident stmts) =
hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
= Opt_D_dump_cmm
| Opt_D_dump_cps_cmm
| Opt_D_dump_asm
+ | Opt_D_dump_asm_native
+ | Opt_D_dump_asm_liveness
+ | Opt_D_dump_asm_coalesce
+ | Opt_D_dump_asm_regalloc
+ | Opt_D_dump_asm_regalloc_stages
+ | Opt_D_dump_asm_conflicts
| Opt_D_dump_cpranal
| Opt_D_dump_deriv
| Opt_D_dump_ds
| Opt_DictsCheap
| Opt_RewriteRules
| Opt_Vectorise
+ | Opt_RegsGraph
-- misc opts
| Opt_Cpp
, ( "ddump-cmm", setDumpFlag Opt_D_dump_cmm)
, ( "ddump-cps-cmm", setDumpFlag Opt_D_dump_cps_cmm)
, ( "ddump-asm", setDumpFlag Opt_D_dump_asm)
+ , ( "ddump-asm-native", setDumpFlag Opt_D_dump_asm_native)
+ , ( "ddump-asm-liveness", setDumpFlag Opt_D_dump_asm_liveness)
+ , ( "ddump-asm-coalesce", setDumpFlag Opt_D_dump_asm_coalesce)
+ , ( "ddump-asm-regalloc", setDumpFlag Opt_D_dump_asm_regalloc)
+ , ( "ddump-asm-conflicts", setDumpFlag Opt_D_dump_asm_conflicts)
+ , ( "ddump-asm-regalloc-stages",
+ setDumpFlag Opt_D_dump_asm_regalloc_stages)
, ( "ddump-cpranal", setDumpFlag Opt_D_dump_cpranal)
, ( "ddump-deriv", setDumpFlag Opt_D_dump_deriv)
, ( "ddump-ds", setDumpFlag Opt_D_dump_ds)
( "rewrite-rules", Opt_RewriteRules ),
( "break-on-exception", Opt_BreakOnException ),
( "vectorise", Opt_Vectorise ),
+ ( "regs-graph", Opt_RegsGraph),
-- Deprecated in favour of -XTemplateHaskell:
( "th", Opt_TemplateHaskell ),
-- Deprecated in favour of -XForeignFunctionInterface:
import MachRegs
import MachCodeGen
import PprMach
-import RegisterAlloc
import RegAllocInfo
import NCGMonad
import PositionIndependentCode
+import RegAllocLinear
+import RegLiveness
+import RegCoalesce
+import qualified RegAllocColor as Color
+import qualified GraphColor as Color
import Cmm
import CmmOpt ( cmmMiniInline, cmmMachOpFold )
-import PprCmm ( pprStmt, pprCmms )
+import PprCmm ( pprStmt, pprCmms, pprCmm )
import MachOp
import CLabel
import qualified Pretty
import Outputable
import FastString
+import UniqSet
-- DEBUGGING ONLY
--import OrdList
import Data.Int
import Data.Word
import Data.Bits
+import Data.Maybe
import GHC.Exts
{-
-- NB. We *lazilly* compile each block of code for space reasons.
+--------------------
nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc
nativeCodeGen dflags cmms us
= let (res, _) = initUs us $
cgCmm (concat (map add_split cmms))
- cgCmm :: [RawCmmTop] -> UniqSM (RawCmm, Pretty.Doc, [CLabel])
+ cgCmm :: [RawCmmTop] -> UniqSM ( [CmmNativeGenDump], Pretty.Doc, [CLabel])
cgCmm tops =
lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results ->
- case unzip3 results of { (cmms,docs,imps) ->
- returnUs (Cmm cmms, my_vcat docs, concat imps)
+ case unzip3 results of { (dump,docs,imps) ->
+ returnUs (dump, my_vcat docs, concat imps)
}
in
- case res of { (ppr_cmms, insn_sdoc, imports) -> do
- dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmms [ppr_cmms])
+ case res of { (dump, insn_sdoc, imports) -> do
+
+ -- stripe across the outputs for each block so all the information for a
+ -- certain stage is concurrent in the dumps.
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_opt_cmm "Optimised Cmm"
+ (pprCmm $ Cmm $ map cdCmmOpt dump)
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_native "(asm-native) Native code"
+ (vcat $ map (docToSDoc . pprNatCmmTop) $ concatMap cdNative dump)
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_liveness "(asm-liveness) Liveness info added"
+ (vcat $ map (ppr . cdLiveness) dump)
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_coalesce "(asm-coalesce) Register moves coalesced."
+ (vcat $ map (ppr . cdCoalesce) dump)
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc "(asm-regalloc) Registers allocated"
+ (vcat $ map (docToSDoc . pprNatCmmTop) $ concatMap cdAlloced dump)
+
+ -- with the graph coloring allocator, show the result of each build/spill stage
+ -- for each block in turn.
+ mapM_ (\codeGraphs
+ -> dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc_stages
+ "(asm-regalloc-stages)"
+ (vcat $ map (\(stage, (code, graph)) ->
+ ( text "-- Stage " <> int stage
+ $$ ppr code
+ $$ Color.dotGraph Color.regDotColor trivColorable graph))
+ (zip [0..] codeGraphs)))
+ $ map cdCodeGraphs dump
+
+ -- Build a global register conflict graph.
+ -- If you want to see the graph for just one basic block then use asm-regalloc-stages instead.
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_conflicts "(asm-conflicts) Register conflict graph"
+ $ Color.dotGraph Color.regDotColor trivColorable
+ $ foldl Color.union Color.initGraph
+ $ catMaybes $ map cdColoredGraph dump
+
+
return (insn_sdoc Pretty.$$ dyld_stubs imports
+
#if HAVE_SUBSECTIONS_VIA_SYMBOLS
-- On recent versions of Darwin, the linker supports
-- dead-stripping of code and data on a per-symbol basis.
#endif
--- Complete native code generation phase for a single top-level chunk
--- of Cmm.
+-- Carries output of the code generator passes, for dumping.
+-- Make sure to only fill the one's we're interested in to avoid
+-- creating space leaks.
+
+data CmmNativeGenDump
+ = CmmNativeGenDump
+ { cdCmmOpt :: RawCmmTop
+ , cdNative :: [NatCmmTop]
+ , cdLiveness :: [LiveCmmTop]
+ , cdCoalesce :: [LiveCmmTop]
+ , cdCodeGraphs :: [([LiveCmmTop], Color.Graph Reg RegClass Reg)]
+ , cdColoredGraph :: Maybe (Color.Graph Reg RegClass Reg)
+ , cdAlloced :: [NatCmmTop] }
-cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (RawCmmTop, Pretty.Doc, [CLabel])
+dchoose dflags opt a b
+ | dopt opt dflags = a
+ | otherwise = b
+
+
+-- | Complete native code generation phase for a single top-level chunk of Cmm.
+-- Unless they're being dumped, intermediate data structures are squashed after
+-- every stage to avoid creating space leaks.
+--
+cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (CmmNativeGenDump, Pretty.Doc, [CLabel])
cmmNativeGen dflags cmm
- = {-# SCC "fixAssigns" #-}
- fixAssignsTop cmm `thenUs` \ fixed_cmm ->
- {-# SCC "genericOpt" #-}
- cmmToCmm dflags fixed_cmm `bind` \ (cmm, imports) ->
- (if dopt Opt_D_dump_opt_cmm dflags -- space leak avoidance
- then cmm
- else CmmData Text []) `bind` \ ppr_cmm ->
- {-# SCC "genMachCode" #-}
- genMachCode dflags cmm `thenUs` \ (pre_regalloc, lastMinuteImports) ->
- {-# SCC "regAlloc" #-}
- mapUs regAlloc pre_regalloc `thenUs` \ with_regs ->
- {-# SCC "shortcutBranches" #-}
- shortcutBranches dflags with_regs `bind` \ shorted ->
- {-# SCC "sequenceBlocks" #-}
- map sequenceTop shorted `bind` \ sequenced ->
- {-# SCC "x86fp_kludge" #-}
- map x86fp_kludge sequenced `bind` \ final_mach_code ->
- {-# SCC "vcat" #-}
- Pretty.vcat (map pprNatCmmTop final_mach_code) `bind` \ final_sdoc ->
-
- returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports)
- where
- x86fp_kludge :: NatCmmTop -> NatCmmTop
- x86fp_kludge top@(CmmData _ _) = top
+ = do
+ --
+ fixed_cmm
+ <- {-# SCC "fixAssigns" #-}
+ fixAssignsTop cmm
+
+ ---- cmm to cmm optimisations
+ (cmm, imports, ppr_cmm)
+ <- (\fixed_cmm
+ -> {-# SCC "genericOpt" #-}
+ do let (cmm, imports) = cmmToCmm dflags fixed_cmm
+
+ return ( cmm
+ , imports
+ , dchoose dflags Opt_D_dump_cmm cmm (CmmData Text []))
+ ) fixed_cmm
+
+
+ ---- generate native code from cmm
+ (native, lastMinuteImports, ppr_native)
+ <- (\cmm
+ -> {-# SCC "genMachCode" #-}
+ do (machCode, lastMinuteImports)
+ <- genMachCode dflags cmm
+
+ return ( machCode
+ , lastMinuteImports
+ , dchoose dflags Opt_D_dump_asm_native machCode [])
+ ) cmm
+
+
+ ---- tag instructions with register liveness information
+ (withLiveness, ppr_withLiveness)
+ <- (\native
+ -> {-# SCC "regLiveness" #-}
+ do
+ withLiveness <- mapUs regLiveness native
+
+ return ( withLiveness
+ , dchoose dflags Opt_D_dump_asm_liveness withLiveness []))
+ native
+
+ ---- allocate registers
+ (alloced, ppr_alloced, ppr_coalesce, ppr_codeGraphs, ppr_coloredGraph)
+ <- (\withLiveness
+ -> {-# SCC "regAlloc" #-}
+ do
+ if dopt Opt_RegsGraph dflags
+ then do
+ -- the regs usable for allocation
+ let alloc_regs
+ = foldr (\r -> plusUFM_C unionUniqSets
+ $ unitUFM (regClass r) (unitUniqSet r))
+ emptyUFM
+ $ map RealReg allocatableRegs
+
+ -- aggressively coalesce moves between virtual regs
+ coalesced <- regCoalesce withLiveness
+
+ -- graph coloring register allocation
+ (alloced, codeGraphs)
+ <- Color.regAlloc
+ alloc_regs
+ (mkUniqSet [0..maxSpillSlots])
+ coalesced
+
+ return ( alloced
+ , dchoose dflags Opt_D_dump_asm_regalloc alloced []
+ , dchoose dflags Opt_D_dump_asm_coalesce coalesced []
+ , dchoose dflags Opt_D_dump_asm_regalloc_stages codeGraphs []
+ , dchoose dflags Opt_D_dump_asm_conflicts Nothing Nothing)
+
+ else do
+ -- do linear register allocation
+ alloced <- mapUs regAlloc withLiveness
+ return ( alloced
+ , dchoose dflags Opt_D_dump_asm_regalloc alloced []
+ , []
+ , []
+ , Nothing ))
+ withLiveness
+
+
+ ---- shortcut branches
+ let shorted =
+ {-# SCC "shortcutBranches" #-}
+ shortcutBranches dflags alloced
+
+ ---- sequence blocks
+ let sequenced =
+ {-# SCC "sequenceBlocks" #-}
+ map sequenceTop shorted
+
+ ---- x86fp_kludge
+ let final_mach_code =
#if i386_TARGET_ARCH
- x86fp_kludge top@(CmmProc info lbl params code) =
- CmmProc info lbl params (map bb_i386_insert_ffrees code)
- where
- bb_i386_insert_ffrees (BasicBlock id instrs) =
- BasicBlock id (i386_insert_ffrees instrs)
+ {-# SCC "x86fp_kludge" #-}
+ map x86fp_kludge sequenced
#else
- x86fp_kludge top = top
+ sequenced
+#endif
+
+ ---- vcat
+ let final_sdoc =
+ {-# SCC "vcat" #-}
+ Pretty.vcat (map pprNatCmmTop final_mach_code)
+
+ let dump =
+ CmmNativeGenDump
+ { cdCmmOpt = ppr_cmm
+ , cdNative = ppr_native
+ , cdLiveness = ppr_withLiveness
+ , cdCoalesce = ppr_coalesce
+ , cdCodeGraphs = ppr_codeGraphs
+ , cdColoredGraph = ppr_coloredGraph
+ , cdAlloced = ppr_alloced }
+
+ returnUs (dump, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports)
+
+#if i386_TARGET_ARCH
+x86fp_kludge :: NatCmmTop -> NatCmmTop
+x86fp_kludge top@(CmmData _ _) = top
+x86fp_kludge top@(CmmProc info lbl params code) =
+ CmmProc info lbl params (map bb_i386_insert_ffrees code)
+ where
+ bb_i386_insert_ffrees (BasicBlock id instrs) =
+ BasicBlock id (i386_insert_ffrees instrs)
#endif
+
-- -----------------------------------------------------------------------------
-- Sequencing the basic blocks
--- /dev/null
+
+-- | Types for the general graph colorer.
+module GraphBase (
+ Triv,
+ Graph (..),
+ initGraph,
+ graphMapModify,
+
+ Node (..), newNode,
+)
+
+
+where
+
+import UniqSet
+import UniqFM
+
+-- | A fn to check if a node is trivially colorable
+-- For graphs who's color classes are disjoint then a node is 'trivially colorable'
+-- when it has less neighbors and exclusions than available colors for that node.
+--
+-- For graph's who's color classes overlap, ie some colors alias other colors, then
+-- this can be a bit more tricky. There is a general way to calculate this, but
+-- it's likely be too slow for use in the code. The coloring algorithm takes
+-- a canned function which can be optimised by the user to be specific to the
+-- specific graph being colored.
+--
+-- for details, see "A Generalised Algorithm for Graph-Coloring Register Allocation"
+-- Smith, Ramsey, Holloway - PLDI 2004.
+--
+type Triv k cls color
+ = cls -- ^ the class of the node we're trying to color.
+ -> UniqSet k -- ^ the node's neighbors.
+ -> UniqSet color -- ^ the node's exclusions.
+ -> Bool
+
+
+-- | The Interference graph.
+-- There used to be more fields, but they were turfed out in a previous revision.
+-- maybe we'll want more later..
+--
+data Graph k cls color
+ = Graph {
+ -- | All active nodes in the graph.
+ graphMap :: UniqFM (Node k cls color) }
+
+-- | An empty graph.
+initGraph
+ = Graph
+ { graphMap = emptyUFM }
+
+
+-- | Modify the finite map holding the nodes in the graph.
+graphMapModify
+ :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color))
+ -> Graph k cls color -> Graph k cls color
+
+graphMapModify f graph
+ = graph { graphMap = f (graphMap graph) }
+
+
+
+-- | Graph nodes.
+-- Represents a thing that can conflict with another thing.
+-- For the register allocater the nodes represent registers.
+--
+data Node k cls color
+ = Node {
+ -- | A unique identifier for this node.
+ nodeId :: k
+
+ -- | The class of this node,
+ -- determines the set of colors that can be used.
+ , nodeClass :: cls
+
+ -- | The color of this node, if any.
+ , nodeColor :: Maybe color
+
+ -- | Neighbors which must be colored differently to this node.
+ , nodeConflicts :: UniqSet k
+
+ -- | Colors that cannot be used by this node.
+ , nodeExclusions :: UniqSet color
+
+ -- | Colors that this node would prefer to be, in decending order.
+ , nodePreference :: [color]
+
+ -- | Neighbors that this node would like to be colored the same as.
+ , nodeCoalesce :: UniqSet k }
+
+
+-- | An empty node.
+newNode :: k -> cls -> Node k cls color
+newNode k cls
+ = Node
+ { nodeId = k
+ , nodeClass = cls
+ , nodeColor = Nothing
+ , nodeConflicts = emptyUniqSet
+ , nodeExclusions = emptyUniqSet
+ , nodePreference = []
+ , nodeCoalesce = emptyUniqSet }
+
+
+
+
--- /dev/null
+
+-- | Graph Coloring.
+-- This is a generic graph coloring library, abstracted over the type of
+-- the node keys, nodes and colors.
+--
+module GraphColor (
+ module GraphBase,
+ module GraphOps,
+ module GraphPpr,
+ colorGraph
+)
+
+where
+
+import GraphBase
+import GraphOps
+import GraphPpr
+
+import Unique
+import UniqFM
+import UniqSet
+import Outputable
+
+import Data.Maybe
+import Data.List
+
+
+-- | Try to color a graph with this set of colors.
+-- Uses Chaitin's algorithm to color the graph.
+-- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes
+-- are pushed onto a stack and removed from the graph.
+-- Once this process is complete the graph can be colored by removing nodes from
+-- the stack (ie in reverse order) and assigning them colors different to their neighbors.
+--
+colorGraph
+ :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color
+ , Outputable k, Outputable cls, Outputable color)
+ => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
+ -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable.
+ -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
+ -> Graph k cls color -- ^ the graph to color.
+ -> ( Graph k cls color -- ^ the colored graph.
+ , UniqSet k ) -- ^ the set of nodes that we couldn't find a color for.
+
+colorGraph colors triv spill graph0
+ = let -- run the scanner to slurp out all the trivially colorable nodes
+ (ksTriv, ksProblems) = colorScan colors triv spill [] emptyUniqSet graph0
+
+ -- color the trivially colorable nodes
+ (graph1, ksNoTriv) = assignColors colors graph0 ksTriv
+
+ -- try and color the problem nodes
+ (graph2, ksNoColor) = assignColors colors graph1 (uniqSetToList ksProblems)
+
+ -- if the trivially colorable nodes didn't color then something is wrong
+ -- with the provided triv function.
+ in if not $ null ksNoTriv
+ then pprPanic "colorGraph: trivially colorable nodes didn't color!" empty
+{- ( empty
+ $$ text "ksTriv = " <> ppr ksTriv
+ $$ text "ksNoTriv = " <> ppr ksNoTriv
+ $$ empty
+ $$ dotGraph (\x -> text "white") triv graph1) -}
+ else (graph2, mkUniqSet ksNoColor)
+
+
+colorScan colors triv spill safe prob graph
+
+ -- empty graphs are easy to color.
+ | isNullUFM $ graphMap graph
+ = (safe, prob)
+
+ -- Try and find a trivially colorable node.
+ | Just node <- find (\node -> triv (nodeClass node)
+ (nodeConflicts node)
+ (nodeExclusions node))
+ $ eltsUFM $ graphMap graph
+ , k <- nodeId node
+ = colorScan colors triv spill
+ (k : safe) prob (delNode k graph)
+
+ -- There was no trivially colorable node,
+ -- Choose one to potentially leave uncolored. We /might/ be able to find
+ -- a color for this later on, but no guarantees.
+ | k <- spill graph
+ = colorScan colors triv spill
+ safe (addOneToUniqSet prob k) (delNode k graph)
+
+
+
+-- | Try to assign a color to all these nodes.
+
+assignColors
+ :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color )
+ => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
+ -> Graph k cls color -- ^ the graph
+ -> [k] -- ^ nodes to assign a color to.
+ -> ( Graph k cls color -- the colored graph
+ , [k]) -- the nodes that didn't color.
+
+assignColors colors graph ks
+ = assignColors' colors graph [] ks
+
+ where assignColors' colors graph prob []
+ = (graph, prob)
+
+ assignColors' colors graph prob (k:ks)
+ = case assignColor colors k graph of
+
+ -- couldn't color this node
+ Nothing -> assignColors' colors graph (k : prob) ks
+
+ -- this node colored ok, so do the rest
+ Just graph' -> assignColors' colors graph' prob ks
+
+
+ assignColor colors u graph
+ | Just c <- selectColor colors graph u
+ = Just (setColor u c graph)
+
+ | otherwise
+ = Nothing
+
+
+
+-- | Select a color for a certain node
+-- taking into account preferences, neighbors and exclusions.
+-- returns Nothing if no color can be assigned to this node.
+--
+-- TODO: avoid using the prefs of the neighbors, if at all possible.
+--
+selectColor
+ :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color)
+ => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
+ -> Graph k cls color -- ^ the graph
+ -> k -- ^ key of the node to select a color for.
+ -> Maybe color
+
+selectColor colors graph u
+ = let -- lookup the node
+ Just node = lookupNode graph u
+
+ -- lookup the available colors for the class of this node.
+ Just colors_avail
+ = lookupUFM colors (nodeClass node)
+
+ -- colors we can't use because they're already being used
+ -- by a node that conflicts with this one.
+ Just nsConflicts
+ = sequence
+ $ map (lookupNode graph)
+ $ uniqSetToList
+ $ nodeConflicts node
+
+ colors_conflict = mkUniqSet
+ $ catMaybes
+ $ map nodeColor nsConflicts
+
+ -- colors that are still ok
+ colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node)
+ colors_ok = minusUniqSet colors_ok_ex colors_conflict
+
+ -- the colors that we prefer, and are still ok
+ colors_ok_pref = intersectUniqSets
+ (mkUniqSet $ nodePreference node) colors_ok
+
+ -- make the decision
+ chooseColor
+
+ -- we got one of our preferences, score!
+ | not $ isEmptyUniqSet colors_ok_pref
+ , c : rest <- uniqSetToList colors_ok_pref
+ = Just c
+
+ -- it wasn't a preference, but it was still ok
+ | not $ isEmptyUniqSet colors_ok
+ , c : rest <- uniqSetToList colors_ok
+ = Just c
+
+ -- leave this node uncolored
+ | otherwise
+ = Nothing
+
+ in chooseColor
+
+
+
--- /dev/null
+
+-- | Basic operations on graphs.
+--
+module GraphOps (
+ addNode, delNode, getNode, lookupNode, modNode,
+ size,
+ union,
+ addConflict, delConflict, addConflicts,
+ addCoalesce, delCoalesce,
+ addExclusion,
+ addPreference,
+ setColor,
+ verify
+)
+where
+
+import GraphBase
+
+import Outputable
+import Unique
+import UniqSet
+import UniqFM
+
+import Data.List hiding (union)
+import Data.Maybe
+
+
+-- | Lookup a node from the graph.
+lookupNode
+ :: Uniquable k
+ => Graph k cls color
+ -> k -> Maybe (Node k cls color)
+
+lookupNode graph k
+ = lookupUFM (graphMap graph) k
+
+
+-- | Get a node from the graph, throwing an error if it's not there
+getNode
+ :: Uniquable k
+ => Graph k cls color
+ -> k -> Node k cls color
+
+getNode graph k
+ = case lookupUFM (graphMap graph) k of
+ Just node -> node
+ Nothing -> panic "ColorOps.getNode: not found"
+
+
+-- | Add a node to the graph, linking up its edges
+addNode :: Uniquable k
+ => k -> Node k cls color
+ -> Graph k cls color -> Graph k cls color
+
+addNode k node graph
+ = let
+ -- add back conflict edges from other nodes to this one
+ map_conflict
+ = foldUniqSet
+ (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
+ (graphMap graph)
+ (nodeConflicts node)
+
+ -- add back coalesce edges from other nodes to this one
+ map_coalesce
+ = foldUniqSet
+ (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
+ map_conflict
+ (nodeCoalesce node)
+
+ in graph
+ { graphMap = addToUFM map_coalesce k node}
+
+
+
+-- | Delete a node and all its edges from the graph.
+-- Throws an error if it's not there.
+delNode :: Uniquable k
+ => k -> Graph k cls color -> Graph k cls color
+
+delNode k graph
+ = let Just node = lookupNode graph k
+
+ -- delete conflict edges from other nodes to this one.
+ graph1 = foldl' (\g k1 -> delConflict k1 k g) graph
+ $ uniqSetToList (nodeConflicts node)
+
+ -- delete coalesce edge from other nodes to this one.
+ graph2 = foldl' (\g k1 -> delCoalesce k1 k g) graph1
+ $ uniqSetToList (nodeCoalesce node)
+
+ -- delete the node
+ graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2
+
+ in graph3
+
+
+-- | Modify a node in the graph
+modNode :: Uniquable k
+ => (Node k cls color -> Node k cls color)
+ -> k -> Graph k cls color -> Graph k cls color
+
+modNode f k graph
+ = case getNode graph k of
+ Node{} -> graphMapModify
+ (\fm -> let Just node = lookupUFM fm k
+ node' = f node
+ in addToUFM fm k node')
+ graph
+
+
+-- | Get the size of the graph, O(n)
+size :: Uniquable k
+ => Graph k cls color -> Int
+
+size graph
+ = sizeUFM $ graphMap graph
+
+
+-- | Union two graphs together.
+union :: Uniquable k
+ => Graph k cls color -> Graph k cls color -> Graph k cls color
+
+union graph1 graph2
+ = Graph
+ { graphMap = plusUFM (graphMap graph1) (graphMap graph2) }
+
+
+
+
+-- | Add a conflict between nodes to the graph, creating the nodes required.
+-- Conflicts are virtual regs which need to be colored differently.
+addConflict
+ :: Uniquable k
+ => (k, cls) -> (k, cls)
+ -> Graph k cls color -> Graph k cls color
+
+addConflict (u1, c1) (u2, c2)
+ = let addNeighbor u c u'
+ = adjustWithDefaultUFM
+ (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
+ (newNode u c) { nodeConflicts = unitUniqSet u' }
+ u
+
+ in graphMapModify
+ ( addNeighbor u1 c1 u2
+ . addNeighbor u2 c2 u1)
+
+
+-- | Delete a conflict edge. k1 -> k2
+delConflict
+ :: Uniquable k
+ => k -> k
+ -> Graph k cls color -> Graph k cls color
+
+delConflict k1 k2
+ = modNode
+ (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
+ k1
+
+
+-- | Add some conflicts to the graph, creating nodes if required.
+-- All the nodes in the set are taken to conflict with each other.
+addConflicts
+ :: Uniquable k
+ => UniqSet k -> (k -> cls)
+ -> Graph k cls color -> Graph k cls color
+
+addConflicts conflicts getClass
+
+ -- just a single node, but no conflicts, create the node anyway.
+ | (u : []) <- uniqSetToList conflicts
+ = graphMapModify
+ $ adjustWithDefaultUFM
+ id
+ (newNode u (getClass u))
+ u
+
+ | otherwise
+ = graphMapModify
+ $ (\fm -> foldr (\u -> addConflictSet1 u getClass conflicts) fm
+ $ uniqSetToList conflicts)
+
+
+addConflictSet1 u getClass set
+ = let set' = delOneFromUniqSet set u
+ in adjustWithDefaultUFM
+ (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
+ (newNode u (getClass u)) { nodeConflicts = set' }
+ u
+
+
+-- | Add an exclusion to the graph, creating nodes if required.
+-- These are extra colors that the node cannot use.
+addExclusion
+ :: (Uniquable k, Uniquable color)
+ => k -> (k -> cls) -> color
+ -> Graph k cls color -> Graph k cls color
+
+addExclusion u getClass color
+ = graphMapModify
+ $ adjustWithDefaultUFM
+ (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
+ (newNode u (getClass u)) { nodeExclusions = unitUniqSet color }
+ u
+
+
+-- | Add a coalescence edge to the graph, creating nodes if requried.
+-- It is considered adventageous to assign the same color to nodes in a coalesence.
+addCoalesce
+ :: Uniquable k
+ => (k, cls) -> (k, cls)
+ -> Graph k cls color -> Graph k cls color
+
+addCoalesce (u1, c1) (u2, c2)
+ = let addCoalesce u c u'
+ = adjustWithDefaultUFM
+ (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
+ (newNode u c) { nodeCoalesce = unitUniqSet u' }
+ u
+
+ in graphMapModify
+ ( addCoalesce u1 c1 u2
+ . addCoalesce u2 c2 u1)
+
+
+-- | Delete a coalescence edge (k1 -> k2) from the graph.
+delCoalesce
+ :: Uniquable k
+ => k -> k
+ -> Graph k cls color -> Graph k cls color
+
+delCoalesce k1 k2
+ = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
+ k1
+
+
+-- | Add a color preference to the graph, creating nodes if required.
+-- The most recently added preference is the most prefered.
+-- The algorithm tries to assign a node it's prefered color if possible.
+--
+addPreference
+ :: Uniquable k
+ => (k, cls) -> color
+ -> Graph k cls color -> Graph k cls color
+
+addPreference (u, c) color
+ = graphMapModify
+ $ adjustWithDefaultUFM
+ (\node -> node { nodePreference = color : (nodePreference node) })
+ (newNode u c) { nodePreference = [color] }
+ u
+
+
+-- | Verify the internal structure of a graph
+-- all its edges should point to valid nodes
+--
+verify :: Uniquable k
+ => Graph k cls color
+ -> Bool
+
+verify graph
+ = let edges = unionUniqSets
+ (unionManyUniqSets
+ (map nodeConflicts $ eltsUFM $ graphMap graph))
+ (unionManyUniqSets
+ (map nodeCoalesce $ eltsUFM $ graphMap graph))
+
+ nodes = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
+
+ badEdges = minusUniqSet edges nodes
+
+ in if isEmptyUniqSet badEdges
+ then True
+ else False
+
+
+-- | Set the color of a certain node
+setColor
+ :: Uniquable k
+ => k -> color
+ -> Graph k cls color -> Graph k cls color
+
+setColor u color
+ = graphMapModify
+ $ adjustUFM
+ (\n -> n { nodeColor = Just color })
+ u
+
+
+adjustWithDefaultUFM
+ :: Uniquable k
+ => (a -> a) -> a -> k
+ -> UniqFM a -> UniqFM a
+
+adjustWithDefaultUFM f def k map
+ = addToUFM_C
+ (\old new -> f old)
+ map
+ k def
+
+
+adjustUFM
+ :: Uniquable k
+ => (a -> a)
+ -> k -> UniqFM a -> UniqFM a
+
+adjustUFM f k map
+ = case lookupUFM map k of
+ Nothing -> map
+ Just a -> addToUFM map k (f a)
+
+
--- /dev/null
+
+-- | Pretty printing of graphs.
+
+module GraphPpr (
+ dumpGraph,
+ dotGraph
+)
+where
+
+import GraphBase
+
+import Outputable
+import Unique
+import UniqSet
+import UniqFM
+
+import Data.List
+import Data.Maybe
+
+
+-- | Pretty print a graph in a somewhat human readable format.
+dumpGraph
+ :: (Outputable k, Outputable cls, Outputable color)
+ => Graph k cls color -> SDoc
+
+dumpGraph graph
+ = text "Graph"
+ $$ (vcat $ map dumpNode $ eltsUFM $ graphMap graph)
+
+dumpNode node
+ = text "Node " <> ppr (nodeId node)
+ $$ text "conflicts "
+ <> parens (int (sizeUniqSet $ nodeConflicts node))
+ <> text " = "
+ <> ppr (nodeConflicts node)
+
+ $$ text "exclusions "
+ <> parens (int (sizeUniqSet $ nodeExclusions node))
+ <> text " = "
+ <> ppr (nodeExclusions node)
+
+ $$ text "coalesce "
+ <> parens (int (sizeUniqSet $ nodeCoalesce node))
+ <> text " = "
+ <> ppr (nodeCoalesce node)
+
+ $$ space
+
+
+
+-- | Pretty print a graph in graphviz .dot format.
+-- Conflicts get solid edges.
+-- Coalescences get dashed edges.
+dotGraph
+ :: ( Uniquable k
+ , Outputable k, Outputable cls, Outputable color)
+ => (color -> SDoc) -- | What graphviz color to use for each node color
+ -- It's usually safe to return X11 style colors here,
+ -- ie "red", "green" etc or a hex triplet #aaff55 etc
+ -> Triv k cls color
+ -> Graph k cls color -> SDoc
+
+dotGraph colorMap triv graph
+ = let nodes = eltsUFM $ graphMap graph
+ in vcat
+ ( [ text "graph G {" ]
+ ++ map (dotNode colorMap triv) nodes
+ ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)
+ ++ [ text "}"
+ , space ])
+
+dotNode colorMap triv node
+ = let name = ppr $ nodeId node
+ cls = ppr $ nodeClass node
+
+ excludes
+ = hcat $ punctuate space
+ $ map (\n -> text "-" <> ppr n)
+ $ uniqSetToList $ nodeExclusions node
+
+ preferences
+ = hcat $ punctuate space
+ $ map (\n -> text "+" <> ppr n)
+ $ nodePreference node
+
+ expref = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)]
+ then empty
+ else text "\\n" <> (excludes <+> preferences)
+
+ -- if the node has been colored then show that,
+ -- otherwise indicate whether it looks trivially colorable.
+ color
+ | Just c <- nodeColor node
+ = text "\\n(" <> ppr c <> text ")"
+
+ | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+ = text "\\n(" <> text "triv" <> text ")"
+
+ | otherwise
+ = text "\\n(" <> text "spill?" <> text ")"
+
+ label = name <> text " :: " <> cls
+ <> expref
+ <> color
+
+ pcolorC = case nodeColor node of
+ Nothing -> text "style=filled fillcolor=white"
+ Just c -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c)
+
+
+ pout = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]"
+ <> space <> doubleQuotes name
+ <> text ";"
+
+ in pout
+
+
+-- | Nodes in the graph are doubly linked, but we only want one edge for each
+-- conflict if the graphviz graph. Traverse over the graph, but make sure
+-- to only print the edges for each node once.
+
+dotNodeEdges visited node
+ | elementOfUniqSet (nodeId node) visited
+ = ( visited
+ , Nothing)
+
+ | otherwise
+ = let dconflicts
+ = map (dotEdgeConflict (nodeId node))
+ $ uniqSetToList
+ $ minusUniqSet (nodeConflicts node) visited
+
+ dcoalesces
+ = map (dotEdgeCoalesce (nodeId node))
+ $ uniqSetToList
+ $ minusUniqSet (nodeCoalesce node) visited
+
+ out = vcat dconflicts
+ $$ vcat dcoalesces
+
+ in ( addOneToUniqSet visited (nodeId node)
+ , Just out)
+
+dotEdgeConflict u1 u2
+ = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) <> text ";"
+
+dotEdgeCoalesce u1 u2
+ = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2) <> space <> text "[ style = dashed ];"
+
-- * The 'Reg' type
RegNo,
- Reg(..), isRealReg, isVirtualReg,
+ Reg(..), isRealReg, isVirtualReg, renameVirtualReg,
RegClass(..), regClass,
+ trivColorable,
getHiVRegFromLo,
mkVReg,
import Outputable ( Outputable(..), pprPanic, panic )
import qualified Outputable
import Unique
+import UniqSet
import Constants
import FastTypes
| RcDouble
deriving Eq
+instance Uniquable RegClass where
+ getUnique RcInteger = mkUnique 'L' 0
+ getUnique RcFloat = mkUnique 'L' 1
+ getUnique RcDouble = mkUnique 'L' 2
+
type RegNo = Int
data Reg
isRealReg :: Reg -> Bool
isRealReg = not . isVirtualReg
+renameVirtualReg :: Unique -> Reg -> Reg
+renameVirtualReg u r
+ = case r of
+ RealReg _ -> error "renameVirtualReg: can't change unique on a real reg"
+ VirtualRegI _ -> VirtualRegI u
+ VirtualRegHi _ -> VirtualRegHi u
+ VirtualRegF _ -> VirtualRegF u
+ VirtualRegD _ -> VirtualRegD u
+
instance Show Reg where
show (RealReg i) = showReg i
show (VirtualRegI u) = "%vI_" ++ show u
show (VirtualRegF u) = "%vF_" ++ show u
show (VirtualRegD u) = "%vD_" ++ show u
+instance Outputable RegClass where
+ ppr RcInteger = Outputable.text "I"
+ ppr RcFloat = Outputable.text "F"
+ ppr RcDouble = Outputable.text "D"
+
instance Outputable Reg where
ppr r = Outputable.text (show r)
+
+
+-- trivColorable function for the graph coloring allocator
+-- This gets hammered by scanGraph during register allocation,
+-- so needs to be fairly efficient.
+--
+-- NOTE: This only works for arcitectures with just RcInteger and RcDouble
+-- (which are disjoint) ie. x86, x86_64 and ppc
+--
+trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool
+trivColorable classN conflicts exclusions
+ = let
+ acc r (cd, cf)
+ = case regClass r of
+ RcInteger -> (cd+1, cf)
+ RcDouble -> (cd, cf+1)
+ _ -> panic "MachRegs.trivColorable: reg class not handled"
+
+ tmp = foldUniqSet acc (0, 0) conflicts
+ (rsD, rsFP) = foldUniqSet acc tmp exclusions
+
+ squeese = worst rsD classN RcInteger
+ + worst rsFP classN RcDouble
+
+ in squeese < allocatableRegsInClass classN
+
+
+-- | Worst case displacement
+-- node N of classN has n neighbors of class C.
+--
+-- We currently only have RcInteger and RcDouble, which don't conflict at all.
+-- This is a bit boring compared to what's in RegArchX86.
+--
+worst :: Int -> RegClass -> RegClass -> Int
+worst n classN classC
+ = case classN of
+ RcInteger
+ -> case classC of
+ RcInteger -> min n (allocatableRegsInClass RcInteger)
+ RcDouble -> 0
+
+ RcDouble
+ -> case classC of
+ RcDouble -> min n (allocatableRegsInClass RcDouble)
+ RcInteger -> 0
+
+
-- -----------------------------------------------------------------------------
-- Machine-specific register stuff
fake4 = RealReg 12
fake5 = RealReg 13
+
-- On x86, we might want to have an 8-bit RegClass, which would
-- contain just regs 1-4 (the others don't have 8-bit versions).
-- However, we can get away without this at the moment because the
then regNames !! n
else "%unknown_x86_real_reg_" ++ show n
+
#endif
{-
= let isFree i = isFastTrue (freeReg i)
in filter isFree allMachRegNos
+
+-- | The number of regs in each class.
+-- We go via top level CAFs to ensure that we're not recomputing
+-- the length of these lists each time the fn is called.
+allocatableRegsInClass :: RegClass -> Int
+allocatableRegsInClass cls
+ = case cls of
+ RcInteger -> allocatableRegsInteger
+ RcDouble -> allocatableRegsDouble
+
+allocatableRegsInteger
+ = length $ filter (\r -> regClass r == RcInteger)
+ $ map RealReg allocatableRegs
+
+allocatableRegsDouble
+ = length $ filter (\r -> regClass r == RcDouble)
+ $ map RealReg allocatableRegs
+
+
-- these are the regs which we cannot assume stay alive over a
-- C call.
callClobberedRegs :: [Reg]
#include "nativeGen/NCG.h"
module PprMach (
- pprNatCmmTop, pprBasicBlock,
- pprInstr, pprSize, pprUserReg,
+ pprNatCmmTop, pprBasicBlock, pprSectionHeader, pprData,
+ pprInstr, pprSize, pprUserReg
) where
import Pretty
import FastString
import qualified Outputable
+import Outputable ( Outputable )
import Data.Array.ST
import Data.Word ( Word8 )
-- -----------------------------------------------------------------------------
-- pprInstr: print an 'Instr'
+instance Outputable Instr where
+ ppr instr = Outputable.docToSDoc $ pprInstr instr
+
pprInstr :: Instr -> Doc
--pprInstr (COMMENT s) = empty -- nuke 'em
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack
+{- -- BUGS: changed for coloring allocator
+pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack -- write a pass for this and patch linear allocator with it
| src == dst
=
#if 0 /* #ifdef DEBUG */
#else
empty
#endif
+-}
pprInstr (MOV size src dst)
= pprSizeOpOp SLIT("mov") size src dst
--- /dev/null
+-- | Graph coloring register allocator.
+--
+-- TODO:
+-- Live range splitting:
+-- At the moment regs that are spilled are spilled for all time, even though
+-- we might be able to allocate them a hardreg in different parts of the code.
+--
+-- As we're aggressively coalescing before register allocation proper we're not currently
+-- using the coalescence information present in the graph.
+--
+-- The function that choosing the potential spills could be a bit cleverer.
+--
+-- Colors in graphviz graphs could be nicer.
+--
+
+module RegAllocColor (
+ regAlloc,
+ regDotColor
+)
+
+where
+
+#include "nativeGen/NCG.h"
+
+import qualified GraphColor as Color
+import RegLiveness
+import RegSpill
+import MachRegs
+import MachInstrs
+import RegCoalesce
+import PprMach
+
+import UniqSupply
+import UniqSet
+import UniqFM
+import Bag
+import Outputable
+
+import Data.List
+import Data.Maybe
+import Control.Monad
+
+-- | The maximum number of build/spill cycles we'll allow.
+-- We should only need 3 or 4 cycles tops.
+-- If we run for any longer than this we're probably in an infinite loop,
+-- It's probably better just to bail out and report a bug at this stage.
+maxSpinCount :: Int
+maxSpinCount = 10
+
+
+-- | The top level of the graph coloring register allocator.
+--
+regAlloc
+ :: UniqFM (UniqSet Reg) -- ^ the registers we can use for allocation
+ -> UniqSet Int -- ^ the set of available spill slots.
+ -> [LiveCmmTop] -- ^ code annotated with liveness information.
+ -> UniqSM
+ ( [NatCmmTop] -- ^ code with registers allocated.
+ , [ ( [LiveCmmTop]
+ , Color.Graph Reg RegClass Reg) ]) -- ^ code and graph for each pass
+
+regAlloc regsFree slotsFree code
+ = do
+ (code_final, debug_codeGraphs, graph_final)
+ <- regAlloc_spin 0 trivColorable regsFree slotsFree [] code
+
+ return ( code_final
+ , debug_codeGraphs )
+
+regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
+ = do
+ -- check that we're not running off down the garden path.
+ when (spinCount > maxSpinCount)
+ $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
+ ( text "It looks like the register allocator is stuck in an infinite loop."
+ $$ text "max cycles = " <> int maxSpinCount
+ $$ text "regsFree = " <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg)
+ $ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
+ $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree))
+
+ -- build a conflict graph from the code.
+ graph <- buildGraph code
+
+ -- build a map of how many instructions each reg lives for
+ -- this lazy, it won't be computed unless we need to spill
+ let fmLife = plusUFMs_C (\(r1, l1) (r2, l2) -> (r1, l1 + l2))
+ $ map lifetimeCount code
+
+ -- the function to choose regs to leave uncolored
+ let spill = chooseSpill_maxLife fmLife
+
+ -- try and color the graph
+ let (graph_colored, rsSpill)
+ = Color.colorGraph regsFree triv spill graph
+
+ -- see if we've found a coloring
+ if isEmptyUniqSet rsSpill
+ then do
+ -- patch the registers using the info in the graph
+ let code_patched = map (patchRegsFromGraph graph_colored) code
+ let code_nat = map stripLive code_patched
+
+ return ( code_nat
+ , debug_codeGraphs ++ [(code, graph_colored), (code_patched, graph_colored)]
+ , graph_colored)
+
+ else do
+ -- spill the uncolored regs
+ (code_spilled, slotsFree')
+ <- regSpill code slotsFree rsSpill
+
+ -- recalculate liveness
+ let code_nat = map stripLive code_spilled
+ code_relive <- mapM regLiveness code_nat
+
+ -- try again
+ regAlloc_spin (spinCount + 1) triv regsFree slotsFree'
+ (debug_codeGraphs ++ [(code, graph_colored)])
+ code_relive
+
+
+-----
+-- Simple maxconflicts isn't always good, because we
+-- can naievely end up spilling vregs that only live for one or two instrs.
+--
+{-
+chooseSpill_maxConflicts
+ :: Color.Graph Reg RegClass Reg
+ -> Reg
+
+chooseSpill_maxConflicts graph
+ = let node = maximumBy
+ (\n1 n2 -> compare
+ (sizeUniqSet $ Color.nodeConflicts n1)
+ (sizeUniqSet $ Color.nodeConflicts n2))
+ $ eltsUFM $ Color.graphMap graph
+
+ in Color.nodeId node
+-}
+
+-----
+chooseSpill_maxLife
+ :: UniqFM (Reg, Int)
+ -> Color.Graph Reg RegClass Reg
+ -> Reg
+
+chooseSpill_maxLife life graph
+ = let node = maximumBy (\n1 n2 -> compare (getLife n1) (getLife n2))
+ $ eltsUFM $ Color.graphMap graph
+
+ -- Orphan vregs die in the same instruction they are born in.
+ -- They will be in the graph, but not in the liveness map.
+ -- Their liveness is 0.
+ getLife n
+ = case lookupUFM life (Color.nodeId n) of
+ Just (_, l) -> l
+ Nothing -> 0
+
+ in Color.nodeId node
+
+
+-- | Build a graph from the liveness and coalesce information in this code.
+
+buildGraph
+ :: [LiveCmmTop]
+ -> UniqSM (Color.Graph Reg RegClass Reg)
+
+buildGraph code
+ = do
+ -- Add the reg-reg conflicts to the graph
+ let conflictSets = unionManyBags (map slurpConflicts code)
+ let graph_conflict = foldrBag graphAddConflictSet Color.initGraph conflictSets
+
+
+ -- Add the coalescences edges to the graph.
+ let coalesce = unionManyBags (map slurpJoinMovs code)
+ let graph_coalesce = foldrBag graphAddCoalesce graph_conflict coalesce
+
+ return $ graph_coalesce
+
+
+-- | Add some conflict edges to the graph.
+-- Conflicts between virtual and real regs are recorded as exlusions.
+--
+graphAddConflictSet
+ :: UniqSet Reg
+ -> Color.Graph Reg RegClass Reg
+ -> Color.Graph Reg RegClass Reg
+
+graphAddConflictSet set graph
+ = let reals = filterUFM isRealReg set
+ virtuals = filterUFM (not . isRealReg) set
+
+ graph1 = Color.addConflicts virtuals regClass graph
+ graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 regClass r2)
+ graph1
+ [ (a, b)
+ | a <- uniqSetToList virtuals
+ , b <- uniqSetToList reals]
+
+ in graph2
+
+
+-- | Add some coalesences edges to the graph
+-- Coalesences between virtual and real regs are recorded as preferences.
+--
+graphAddCoalesce
+ :: (Reg, Reg)
+ -> Color.Graph Reg RegClass Reg
+ -> Color.Graph Reg RegClass Reg
+
+graphAddCoalesce (r1, r2) graph
+ | RealReg regno <- r1
+ = Color.addPreference (regWithClass r2) r1 graph
+
+ | RealReg regno <- r2
+ = Color.addPreference (regWithClass r1) r2 graph
+
+ | otherwise
+ = Color.addCoalesce (regWithClass r1) (regWithClass r2) graph
+
+ where regWithClass r = (r, regClass r)
+
+
+-- | Patch registers in code using the reg -> reg mapping in this graph.
+patchRegsFromGraph
+ :: Color.Graph Reg RegClass Reg
+ -> LiveCmmTop -> LiveCmmTop
+
+patchRegsFromGraph graph code
+ = let
+ -- a function to lookup the hardreg for a virtual reg from the graph.
+ patchF reg
+ -- leave real regs alone.
+ | isRealReg reg
+ = reg
+
+ -- this virtual has a regular node in the graph.
+ | Just node <- Color.lookupNode graph reg
+ = case Color.nodeColor node of
+ Just color -> color
+ Nothing -> reg
+
+ -- no node in the graph for this virtual, bad news.
+ | otherwise
+ = pprPanic "patchRegsFromGraph: register mapping failed."
+ ( text "There is no node in the graph for register " <> ppr reg
+ $$ ppr code
+ $$ Color.dotGraph (\x -> text "white") trivColorable graph)
+
+ in patchEraseLive patchF code
+
+
+-----
+-- Register colors for drawing conflict graphs
+-- Keep this out of MachRegs.hs because it's specific to the graph coloring allocator.
+
+
+-- reg colors for x86
+#if i386_TARGET_ARCH
+regDotColor :: Reg -> SDoc
+regDotColor reg
+ = let Just str = lookupUFM regColors reg
+ in text str
+
+regColors
+ = listToUFM
+ $ [ (eax, "#00ff00")
+ , (ebx, "#0000ff")
+ , (ecx, "#00ffff")
+ , (edx, "#0080ff")
+
+ , (fake0, "#ff00ff")
+ , (fake1, "#ff00aa")
+ , (fake2, "#aa00ff")
+ , (fake3, "#aa00aa")
+ , (fake4, "#ff0055")
+ , (fake5, "#5500ff") ]
+#endif
+
+
+-- reg colors for x86_64
+#if x86_64_TARGET_ARCH
+regDotColor :: Reg -> SDoc
+regDotColor reg
+ = let Just str = lookupUFM regColors reg
+ in text str
+
+regColors
+ = listToUFM
+ $ [ (rax, "#00ff00"), (eax, "#00ff00")
+ , (rbx, "#0000ff"), (ebx, "#0000ff")
+ , (rcx, "#00ffff"), (ecx, "#00ffff")
+ , (rdx, "#0080ff"), (edx, "#00ffff")
+ , (r8, "#00ff80")
+ , (r9, "#008080")
+ , (r10, "#0040ff")
+ , (r11, "#00ff40")
+ , (r12, "#008040")
+ , (r13, "#004080")
+ , (r14, "#004040")
+ , (r15, "#002080") ]
+
+ ++ zip (map RealReg [16..31]) (repeat "red")
+#endif
+
+
+-- reg colors for ppc
+#if powerpc_TARGET_ARCH
+regDotColor :: Reg -> SDoc
+regDotColor reg
+ = case regClass reg of
+ RcInteger -> text "blue"
+ RcFloat -> text "red"
+#endif
+
+
+{-
+toX11Color (r, g, b)
+ = let rs = padL 2 '0' (showHex r "")
+ gs = padL 2 '0' (showHex r "")
+ bs = padL 2 '0' (showHex r "")
+
+ padL n c s
+ = replicate (n - length s) c ++ s
+ in "#" ++ rs ++ gs ++ bs
+-}
+
+plusUFMs_C :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
+plusUFMs_C f maps
+ = foldl (plusUFM_C f) emptyUFM maps
+
-> Int -- spill slot to use
-> Instr
mkSpillInstr reg delta slot
- = ASSERT(isRealReg reg)
- let
+ -- = ASSERT(isRealReg reg) -- BUGS: used for graph coloring: is this ok?
+ = let
off = spillSlotToOffset slot
in
#ifdef alpha_TARGET_ARCH
-> Int -- spill slot to use
-> Instr
mkLoadInstr reg delta slot
- = ASSERT(isRealReg reg)
- let
+ -- = ASSERT(isRealReg reg) -- BUGS: used for graph coloring: is this ok?
+ = let
off = spillSlotToOffset slot
in
#if alpha_TARGET_ARCH
= 64 + spillSlotSize * slot
| otherwise
= pprPanic "spillSlotToOffset:"
- (text "invalid spill location: " <> int slot)
+ ( text "invalid spill location: " <> int slot
+ $$ text "maxSpillSlots: " <> int maxSpillSlots)
-}
-module RegisterAlloc (
- regAlloc
+module RegAllocLinear (
+ regAlloc,
) where
#include "HsVersions.h"
-import PprMach
import MachRegs
import MachInstrs
import RegAllocInfo
+import RegLiveness
import Cmm
import Digraph
#ifndef DEBUG
import Data.Maybe ( fromJust )
#endif
-import Data.List ( nub, partition, mapAccumL, groupBy )
+import Data.List ( nub, partition, mapAccumL)
import Control.Monad ( when )
import Data.Word
import Data.Bits
--- -----------------------------------------------------------------------------
--- Some useful types
-
-type RegSet = UniqSet Reg
-
-type RegMap a = UniqFM a
-emptyRegMap = emptyUFM
-
-type BlockMap a = UniqFM a
-emptyBlockMap = emptyUFM
-
--- A basic block where the isntructions are annotated with the registers
--- which are no longer live in the *next* instruction in this sequence.
--- (NB. if the instruction is a jump, these registers might still be live
--- at the jump target(s) - you have to check the liveness at the destination
--- block to find out).
-type AnnBasicBlock
- = GenBasicBlock (Instr,
- [Reg], -- registers read (only) which die
- [Reg]) -- registers written which die
-- -----------------------------------------------------------------------------
-- The free register set
emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM
getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
+getStackSlotFor fs@(StackMap [] reserved) reg
+ = panic "RegAllocLinear.getStackSlotFor: out of stack slots"
getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
case lookupUFM reserved reg of
Just slot -> (fs,slot)
-- -----------------------------------------------------------------------------
-- Top level of the register allocator
-regAlloc :: NatCmmTop -> UniqSM NatCmmTop
-regAlloc (CmmData sec d) = returnUs $ CmmData sec d
-regAlloc (CmmProc info lbl params [])
- = returnUs $ CmmProc info lbl params [] -- no blocks to run the regalloc on
-regAlloc (CmmProc info lbl params blocks@(first:rest))
- = let
- first_id = blockId first
- sccs = sccBlocks blocks
- (ann_sccs, block_live) = computeLiveness sccs
- in linearRegAlloc block_live ann_sccs `thenUs` \final_blocks ->
- let ((first':_),rest') = partition ((== first_id) . blockId) final_blocks
- in returnUs $ -- pprTrace "Liveness" (ppr block_live) $
- CmmProc info lbl params (first':rest')
-
-sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
-sccBlocks blocks = stronglyConnComp graph
- where
- getOutEdges :: [Instr] -> [BlockId]
- getOutEdges instrs = foldr jumpDests [] instrs
+-- Allocate registers
+regAlloc
+ :: LiveCmmTop
+ -> UniqSM NatCmmTop
- graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
- | block@(BasicBlock id instrs) <- blocks ]
+regAlloc cmm@(CmmData sec d)
+ = returnUs $ CmmData sec d
+
+regAlloc cmm@(CmmProc (LiveInfo info _ _) lbl params [])
+ = returnUs $ CmmProc info lbl params []
+
+regAlloc cmm@(CmmProc (LiveInfo info (Just first_id) block_live) lbl params comps)
+ = let ann_sccs = map (\b -> case b of
+ BasicBlock i [b] -> AcyclicSCC b
+ BasicBlock i bs -> CyclicSCC bs)
+ $ comps
+ in linearRegAlloc block_live ann_sccs `thenUs` \final_blocks ->
--- -----------------------------------------------------------------------------
--- Computing liveness
-
-computeLiveness
- :: [SCC NatBasicBlock]
- -> ([SCC AnnBasicBlock], -- instructions annotated with list of registers
- -- which are "dead after this instruction".
- BlockMap RegSet) -- blocks annontated with set of live registers
- -- on entry to the block.
-
- -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
- -- control to earlier ones only. The SCCs returned are in the *opposite*
- -- order, which is exactly what we want for the next pass.
+ let ((first':_), rest') = partition ((== first_id) . blockId) final_blocks
+ in returnUs $ CmmProc info lbl params (first' : rest')
-computeLiveness sccs
- = livenessSCCs emptyBlockMap [] sccs
- where
- livenessSCCs
- :: BlockMap RegSet
- -> [SCC AnnBasicBlock] -- accum
- -> [SCC NatBasicBlock]
- -> ([SCC AnnBasicBlock], BlockMap RegSet)
-
- livenessSCCs blockmap done [] = (done, blockmap)
- livenessSCCs blockmap done
- (AcyclicSCC (BasicBlock block_id instrs) : sccs) =
- {- pprTrace "live instrs" (ppr (getUnique block_id) $$
- vcat (map (\(instr,regs) -> docToSDoc (pprInstr instr) $$ ppr regs) instrs')) $
- -}
- livenessSCCs blockmap'
- (AcyclicSCC (BasicBlock block_id instrs'):done) sccs
- where (live,instrs') = liveness emptyUniqSet blockmap []
- (reverse instrs)
- blockmap' = addToUFM blockmap block_id live
-
- livenessSCCs blockmap done
- (CyclicSCC blocks : sccs) =
- livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
- where (blockmap', blocks')
- = iterateUntilUnchanged linearLiveness equalBlockMaps
- blockmap blocks
-
- iterateUntilUnchanged
- :: (a -> b -> (a,c)) -> (a -> a -> Bool)
- -> a -> b
- -> (a,c)
-
- iterateUntilUnchanged f eq a b
- = head $
- concatMap tail $
- groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
- iterate (\(a, _) -> f a b) $
- (a, error "RegisterAlloc.livenessSCCs")
-
-
- linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
- -> (BlockMap RegSet, [AnnBasicBlock])
- linearLiveness = mapAccumL processBlock
-
- processBlock blockmap input@(BasicBlock block_id instrs)
- = (blockmap', BasicBlock block_id instrs')
- where (live,instrs') = liveness emptyUniqSet blockmap []
- (reverse instrs)
- blockmap' = addToUFM blockmap block_id live
-
- -- probably the least efficient way to compare two
- -- BlockMaps for equality.
- equalBlockMaps a b
- = a' == b'
- where a' = map f $ ufmToList a
- b' = map f $ ufmToList b
- f (key,elt) = (key, uniqSetToList elt)
-
- liveness :: RegSet -- live regs
- -> BlockMap RegSet -- live regs on entry to other BBs
- -> [(Instr,[Reg],[Reg])] -- instructions (accum)
- -> [Instr] -- instructions
- -> (RegSet, [(Instr,[Reg],[Reg])])
-
- liveness liveregs blockmap done [] = (liveregs, done)
- liveness liveregs blockmap done (instr:instrs)
- | not_a_branch = liveness liveregs1 blockmap
- ((instr,r_dying,w_dying):done) instrs
- | otherwise = liveness liveregs_br blockmap
- ((instr,r_dying_br,w_dying):done) instrs
- where
- RU read written = regUsage instr
-
- -- registers that were written here are dead going backwards.
- -- registers that were read here are live going backwards.
- liveregs1 = (liveregs `delListFromUniqSet` written)
- `addListToUniqSet` read
-
- -- registers that are not live beyond this point, are recorded
- -- as dying here.
- r_dying = [ reg | reg <- read, reg `notElem` written,
- not (elementOfUniqSet reg liveregs) ]
-
- w_dying = [ reg | reg <- written,
- not (elementOfUniqSet reg liveregs) ]
-
- -- union in the live regs from all the jump destinations of this
- -- instruction.
- targets = jumpDests instr [] -- where we go from here
- not_a_branch = null targets
-
- targetLiveRegs target = case lookupUFM blockmap target of
- Just ra -> ra
- Nothing -> emptyBlockMap
-
- live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
-
- liveregs_br = liveregs1 `unionUniqSets` live_from_branch
-
- -- registers that are live only in the branch targets should
- -- be listed as dying here.
- live_branch_only = live_from_branch `minusUniqSet` liveregs
- r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`
- live_branch_only)
+
-- -----------------------------------------------------------------------------
-- Linear sweep to allocate registers
linearRegAlloc
:: BlockMap RegSet -- live regs on entry to each basic block
- -> [SCC AnnBasicBlock] -- instructions annotated with "deaths"
+ -> [SCC LiveBasicBlock] -- instructions annotated with "deaths"
-> UniqSM [NatBasicBlock]
linearRegAlloc block_live sccs = linearRA_SCCs emptyBlockMap emptyStackMap sccs
where
linearRA_SCCs
:: BlockAssignment
-> StackMap
- -> [SCC AnnBasicBlock]
+ -> [SCC LiveBasicBlock]
-> UniqSM [NatBasicBlock]
linearRA_SCCs block_assig stack [] = returnUs []
linearRA_SCCs block_assig stack
runR block_assig freeregs assig stack us $
linearRA [] [] instrs
- linearRA :: [Instr] -> [NatBasicBlock] -> [(Instr,[Reg],[Reg])]
+ linearRA :: [Instr] -> [NatBasicBlock] -> [LiveInstr]
-> RegM ([Instr], [NatBasicBlock])
linearRA instr_acc fixups [] =
return (reverse instr_acc, fixups)
raInsn :: BlockMap RegSet -- Live temporaries at each basic block
-> [Instr] -- new instructions (accum.)
- -> (Instr,[Reg],[Reg]) -- the instruction (with "deaths")
+ -> LiveInstr -- the instruction (with "deaths")
-> RegM (
[Instr], -- new instructions
[NatBasicBlock] -- extra fixup blocks
)
-raInsn block_live new_instrs (instr@(DELTA n), _, _) = do
+raInsn block_live new_instrs (Instr instr@(COMMENT _) Nothing)
+ = return (new_instrs, [])
+
+raInsn block_live new_instrs (Instr instr@(DELTA n) Nothing)
+ = do
setDeltaR n
return (new_instrs, [])
-raInsn block_live new_instrs (instr, r_dying, w_dying) = do
+raInsn block_live new_instrs (Instr instr (Just live))
+ = do
assig <- getAssigR
-- If we have a reg->reg move between virtual registers, where the
-- (we can't eliminitate it if the source register is on the stack, because
-- we do not want to use one spill slot for different virtual registers)
case isRegRegMove instr of
- Just (src,dst) | src `elem` r_dying,
+ Just (src,dst) | src `elementOfUniqSet` (liveDieRead live),
isVirtualReg dst,
not (dst `elemUFM` assig),
Just (InReg _) <- (lookupUFM assig src) -> do
-}
return (new_instrs, [])
- other -> genRaInsn block_live new_instrs instr r_dying w_dying
+ other -> genRaInsn block_live new_instrs instr
+ (uniqSetToList $ liveDieRead live)
+ (uniqSetToList $ liveDieWrite live)
+
+
+raInsn block_live new_instrs li
+ = pprPanic "raInsn" (text "no match for:" <> ppr li)
genRaInsn block_live new_instrs instr r_dying w_dying =
= do
--ToDo: copy it to another register if possible
(spill,slot) <- spillR (RealReg reg) temp
- clobber (addToUFM assig temp (InBoth reg slot)) (spill:instrs) rest
+ clobber (addToUFM assig temp (InBoth reg slot)) (spill: COMMENT FSLIT("spill clobber") : instrs) rest
clobberRegs :: [RegNo] -> RegM ()
clobberRegs [] = return () -- common case
-- in
setAssigR assig2
spills' <- do_load reading loc my_reg spills
- allocateRegsAndSpill reading keep (spill_insn:spills')
+ allocateRegsAndSpill reading keep
+ (spill_insn : COMMENT FSLIT("spill alloc") : spills')
(my_reg:alloc) rs
where
-- load up a spilled temporary if we need to
do_load True (Just (InMem slot)) reg spills = do
insn <- loadR (RealReg reg) slot
- return (insn : spills)
+ return (insn : COMMENT FSLIT("spill load") : spills)
do_load _ _ _ spills =
return spills
--- /dev/null
+
+-- | Utils for calculating general worst, bound, squeese and free, functions.
+--
+-- as per: "A Generalized Algorithm for Graph-Coloring Register Allocation"
+-- Michael Smith, Normal Ramsey, Glenn Holloway.
+-- PLDI 2004
+--
+-- These general versions are not used in GHC proper because they are too slow.
+-- Instead, hand written optimised versions are provided for each architecture
+-- in MachRegs*.hs
+--
+-- This code is here because we can test the architecture specific code against it.
+--
+--
+module RegArchBase (
+ RegClass(..),
+ Reg(..),
+ RegSub(..),
+
+ worst,
+ bound,
+ squeese
+)
+
+where
+
+
+-----
+import qualified Data.Set as Set
+import Data.Set (Set)
+
+-- import qualified Data.Map as Map
+-- import Data.Map (Map)
+
+
+-- Some basic register classes.
+-- These aren't nessesarally in 1-to-1 correspondance with the allocatable
+-- RegClasses in MachRegs.hs
+--
+data RegClass
+ -- general purpose regs
+ = ClassG32 -- 32 bit GPRs
+ | ClassG16 -- 16 bit GPRs
+ | ClassG8 -- 8 bit GPRs
+
+ -- floating point regs
+ | ClassF64 -- 64 bit FPRs
+ deriving (Show, Ord, Eq)
+
+
+-- | A register of some class
+data Reg
+ -- a register of some class
+ = Reg RegClass Int
+
+ -- a sub-component of one of the other regs
+ | RegSub RegSub Reg
+ deriving (Show, Ord, Eq)
+
+
+-- | A subcomponent of another register
+data RegSub
+ = SubL16 -- lowest 16 bits
+ | SubL8 -- lowest 8 bits
+ | SubL8H -- second lowest 8 bits
+ deriving (Show, Enum, Ord, Eq)
+
+
+
+-- | Worst case displacement
+--
+-- a node N of classN has some number of neighbors,
+-- all of which are from classC.
+--
+-- (worst neighbors classN classC) is the maximum number of potential
+-- colors for N that can be lost by coloring its neighbors.
+
+-- This should be hand coded/cached for each particular architecture,
+-- because the compute time is very long..
+
+worst
+ :: (RegClass -> Set Reg)
+ -> (Reg -> Set Reg)
+ -> Int -> RegClass -> RegClass -> Int
+
+worst regsOfClass regAlias neighbors classN classC
+ = let regAliasS regs = unionsS $ Set.map regAlias regs
+
+ -- all the regs in classes N, C
+ regsN = regsOfClass classN
+ regsC = regsOfClass classC
+
+ -- all the possible subsets of c which have size < m
+ regsS = Set.filter (\s -> Set.size s >= 1 && Set.size s <= neighbors)
+ $ powerset regsC
+
+ -- for each of the subsets of C, the regs which conflict with posiblities for N
+ regsS_conflict
+ = Set.map (\s -> Set.intersection regsN (regAliasS s)) regsS
+
+ in Set.findMax $ Set.map Set.size $ regsS_conflict
+
+
+-- | For a node N of classN and neighbors of classesC
+-- (bound classN classesC) is the maximum number of potential
+-- colors for N that can be lost by coloring its neighbors.
+--
+
+bound
+ :: (RegClass -> Set Reg)
+ -> (Reg -> Set Reg)
+ -> RegClass -> [RegClass] -> Int
+
+bound regsOfClass regAlias classN classesC
+ = let regAliasS regs = unionsS $ Set.map regAlias regs
+
+ regsC_aliases
+ = Set.unions
+ $ map (regAliasS . regsOfClass) classesC
+
+ overlap = Set.intersection (regsOfClass classN) regsC_aliases
+
+ in Set.size overlap
+
+
+-- | The total squeese on a particular node with a list of neighbors.
+--
+-- A version of this should be constructed for each particular architecture,
+-- possibly including uses of bound, so that alised registers don't get counted
+-- twice, as per the paper.
+--
+squeese
+ :: (RegClass -> Set Reg)
+ -> (Reg -> Set Reg)
+ -> RegClass -> [(Int, RegClass)] -> Int
+
+squeese regsOfClass regAlias classN countCs
+ = sum (map (\(i, classC) -> worst regsOfClass regAlias i classN classC) countCs)
+
+
+-- | powerset (for lists)
+powersetL :: Ord a => [a] -> [[a]]
+powersetL = map concat . mapM (\x -> [[],[x]])
+
+-- | powerset (for sets)
+powerset :: Ord a => Set a -> Set (Set a)
+powerset s = Set.fromList $ map Set.fromList $ powersetL $ Set.toList s
+
+-- | unions (for sets)
+unionsS :: Ord a => Set (Set a) -> Set a
+unionsS ss = Set.unions $ Set.toList ss
+
+
--- /dev/null
+
+-- | A description of the register set of the X86.
+-- This isn't used directly in GHC proper.
+--
+-- See RegArchBase.hs for the reference.
+-- See MachRegs.hs for the actual trivColorable function used in GHC.
+--
+module RegArchX86 (
+ classOfReg,
+ regsOfClass,
+ regName,
+ regAlias,
+ worst,
+ squeese,
+) where
+
+import RegArchBase (Reg(..), RegSub(..), RegClass(..))
+
+import qualified Data.Set as Set
+import Data.Set (Set)
+
+-- | Determine the class of a register
+classOfReg :: Reg -> RegClass
+classOfReg reg
+ = case reg of
+ Reg c i -> c
+
+ RegSub SubL16 r -> ClassG16
+ RegSub SubL8 r -> ClassG8
+ RegSub SubL8H r -> ClassG8
+
+
+-- | Determine all the regs that make up a certain class.
+--
+regsOfClass :: RegClass -> Set Reg
+regsOfClass c
+ = case c of
+ ClassG32
+ -> Set.fromList [ Reg ClassG32 i | i <- [0..7] ]
+
+ ClassG16
+ -> Set.fromList [ RegSub SubL16 (Reg ClassG32 i) | i <- [0..7] ]
+
+ ClassG8
+ -> Set.union
+ (Set.fromList [ RegSub SubL8 (Reg ClassG32 i) | i <- [0..3] ])
+ (Set.fromList [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ])
+
+ ClassF64
+ -> Set.fromList [ Reg ClassF64 i | i <- [0..5] ]
+
+
+-- | Determine the common name of a reg
+-- returns Nothing if this reg is not part of the machine.
+
+regName :: Reg -> Maybe String
+regName reg
+ = case reg of
+ Reg ClassG32 i
+ | i <= 7 -> Just ([ "eax", "ebx", "ecx", "edx", "ebp", "esi", "edi", "esp" ] !! i)
+
+ RegSub SubL16 (Reg ClassG32 i)
+ | i <= 7 -> Just ([ "ax", "bx", "cx", "dx", "bp", "si", "di", "sp"] !! i)
+
+ RegSub SubL8 (Reg ClassG32 i)
+ | i <= 3 -> Just ([ "al", "bl", "cl", "dl"] !! i)
+
+ RegSub SubL8H (Reg ClassG32 i)
+ | i <= 3 -> Just ([ "ah", "bh", "ch", "dh"] !! i)
+
+ _ -> Nothing
+
+
+-- | Which regs alias what other regs
+regAlias :: Reg -> Set Reg
+regAlias reg
+ = case reg of
+
+ -- 32 bit regs alias all of the subregs
+ Reg ClassG32 i
+
+ -- for eax, ebx, ecx, eds
+ | i <= 3
+ -> Set.fromList $ [ Reg ClassG32 i, RegSub SubL16 reg, RegSub SubL8 reg, RegSub SubL8H reg ]
+
+ -- for esi, edi, esp, ebp
+ | 4 <= i && i <= 7
+ -> Set.fromList $ [ Reg ClassG32 i, RegSub SubL16 reg ]
+
+
+ -- 16 bit subregs alias the whole reg
+ RegSub SubL16 r@(Reg ClassG32 i)
+ -> regAlias r
+
+ -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg
+ RegSub SubL8 r@(Reg ClassG32 i)
+ -> Set.fromList $ [ r, RegSub SubL16 r, RegSub SubL8 r ]
+
+ RegSub SubL8H r@(Reg ClassG32 i)
+ -> Set.fromList $ [ r, RegSub SubL16 r, RegSub SubL8H r ]
+
+ -- fp
+ Reg ClassF64 i
+ -> Set.singleton reg
+
+ _ -> error "regAlias: invalid register"
+
+
+-- | Optimised versions of RegColorBase.{worst, squeese} specific to x86
+
+worst :: Int -> RegClass -> RegClass -> Int
+worst n classN classC
+ = case classN of
+ ClassG32
+ -> case classC of
+ ClassG32 -> min n 8
+ ClassG16 -> min n 8
+ ClassG8 -> min n 4
+ ClassF64 -> 0
+
+ ClassG16
+ -> case classC of
+ ClassG32 -> min n 8
+ ClassG16 -> min n 8
+ ClassG8 -> min n 4
+ ClassF64 -> 0
+
+ ClassG8
+ -> case classC of
+ ClassG32 -> min (n*2) 8
+ ClassG16 -> min (n*2) 8
+ ClassG8 -> min n 8
+ ClassF64 -> 0
+
+ ClassF64
+ -> case classC of
+ ClassF64 -> min n 6
+ _ -> 0
+
+squeese :: RegClass -> [(Int, RegClass)] -> Int
+squeese classN countCs
+ = sum (map (\(i, classC) -> worst i classN classC) countCs)
+
+
+
+
+
--- /dev/null
+
+-- | Register coalescing.
+--
+
+module RegCoalesce (
+ regCoalesce,
+ slurpJoinMovs
+)
+
+where
+
+import Cmm
+import MachRegs
+import RegLiveness
+import RegAllocInfo
+
+import Bag
+import UniqFM
+import UniqSet
+import UniqSupply
+
+import Control.Monad
+import Data.List
+
+-- | Do register coalescing on this top level thing
+-- For Reg -> Reg moves, if the first reg dies at the same time the second reg is born
+-- then the mov only serves to join live ranges. The two regs can be renamed to be
+-- the same and the move instruction safely erased.
+
+regCoalesce :: [LiveCmmTop] -> UniqSM [LiveCmmTop]
+regCoalesce code
+ = do
+ let joins = foldl' unionBags emptyBag
+ $ map slurpJoinMovs code
+
+ let alloc = foldl' buildAlloc emptyUFM
+ $ bagToList joins
+
+ let patched = map (patchEraseLive (sinkReg alloc)) code
+
+ return patched
+
+
+buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
+buildAlloc fm (r1, r2)
+ = let rmin = min r1 r2
+ rmax = max r1 r2
+ in addToUFM fm rmax rmin
+
+sinkReg :: UniqFM Reg -> Reg -> Reg
+sinkReg fm r
+ = case lookupUFM fm r of
+ Nothing -> r
+ Just r' -> sinkReg fm r'
+
+
+-- | Slurp out mov instructions that only serve to join live ranges.
+-- During a mov, if the source reg dies and the destiation reg is born
+-- then we can rename the two regs to the same thing and eliminate the move.
+--
+slurpJoinMovs :: LiveCmmTop -> Bag (Reg, Reg)
+slurpJoinMovs live
+ = slurpCmm emptyBag live
+ where
+ slurpCmm rs CmmData{} = rs
+ slurpCmm rs (CmmProc _ _ _ blocks) = foldl' slurpComp rs blocks
+ slurpComp rs (BasicBlock i blocks) = foldl' slurpBlock rs blocks
+ slurpBlock rs (BasicBlock i instrs) = foldl' slurpLI rs instrs
+
+ slurpLI rs (Instr _ Nothing) = rs
+ slurpLI rs (Instr instr (Just live))
+ | Just (r1, r2) <- isRegRegMove instr
+ , elementOfUniqSet r1 $ liveDieRead live
+ , elementOfUniqSet r2 $ liveBorn live
+
+ -- only coalesce movs between two virtuals for now, else we end up with
+ -- allocatable regs in the live regs list..
+ , isVirtualReg r1 && isVirtualReg r2
+ = consBag (r1, r2) rs
+
+ | otherwise
+ = rs
+
+
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- The register liveness determinator
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+
+module RegLiveness (
+ RegSet,
+ RegMap, emptyRegMap,
+ BlockMap, emptyBlockMap,
+ LiveCmmTop,
+ LiveInstr (..),
+ Liveness (..),
+ LiveInfo (..),
+ LiveBasicBlock,
+
+ mapBlockTop,
+ mapBlockTopM,
+ stripLive,
+ slurpConflicts,
+ lifetimeCount,
+ eraseDeltasLive,
+ patchEraseLive,
+ patchRegsLiveInstr,
+ regLiveness
+ ) where
+
+#include "HsVersions.h"
+
+import MachRegs
+import MachInstrs
+import PprMach
+import RegAllocInfo
+import Cmm
+
+import Digraph
+import Outputable
+import Unique
+import UniqSet
+import UniqFM
+import UniqSupply
+import Bag
+import State
+
+import Data.List
+import Data.Maybe
+
+-----------------------------------------------------------------------------
+type RegSet = UniqSet Reg
+
+type RegMap a = UniqFM a
+emptyRegMap = emptyUFM
+
+type BlockMap a = UniqFM a
+emptyBlockMap = emptyUFM
+
+
+-- | A top level thing which carries liveness information.
+type LiveCmmTop
+ = GenCmmTop
+ CmmStatic
+ LiveInfo
+ (GenBasicBlock LiveInstr)
+ -- the "instructions" here are actually more blocks,
+ -- single blocks are acyclic
+ -- multiple blocks are taken to be cyclic.
+
+-- | An instruction with liveness information.
+data LiveInstr
+ = Instr Instr (Maybe Liveness)
+
+-- | Liveness information.
+-- The regs which die are ones which are no longer live in the *next* instruction
+-- in this sequence.
+-- (NB. if the instruction is a jump, these registers might still be live
+-- at the jump target(s) - you have to check the liveness at the destination
+-- block to find out).
+
+data Liveness
+ = Liveness
+ { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time).
+ , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time.
+ , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something.
+
+
+-- | Stash regs live on entry to each basic block in the info part of the cmm code.
+data LiveInfo
+ = LiveInfo
+ [CmmStatic] -- cmm static stuff
+ (Maybe BlockId) -- id of the first block
+ (BlockMap RegSet) -- argument locals live on entry to this block
+
+-- | A basic block with liveness information.
+type LiveBasicBlock
+ = GenBasicBlock LiveInstr
+
+
+instance Outputable LiveInstr where
+ ppr (Instr instr Nothing)
+ = ppr instr
+
+ ppr (Instr instr (Just live))
+ = ppr instr
+ $$ (nest 8
+ $ vcat
+ [ pprRegs (ptext SLIT("# born: ")) (liveBorn live)
+ , pprRegs (ptext SLIT("# r_dying: ")) (liveDieRead live)
+ , pprRegs (ptext SLIT("# w_dying: ")) (liveDieWrite live) ]
+ $+$ space)
+
+ where pprRegs :: SDoc -> RegSet -> SDoc
+ pprRegs name regs
+ | isEmptyUniqSet regs = empty
+ | otherwise = name <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg) $ uniqSetToList regs)
+
+
+instance Outputable LiveInfo where
+ ppr (LiveInfo static firstId liveOnEntry)
+ = (vcat $ map ppr static)
+ $$ text "# firstId = " <> ppr firstId
+ $$ text "# liveOnEntry = " <> ppr liveOnEntry
+
+
+-- | map a function across all the basic blocks in this code
+--
+mapBlockTop
+ :: (LiveBasicBlock -> LiveBasicBlock)
+ -> LiveCmmTop -> LiveCmmTop
+
+mapBlockTop f cmm
+ = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
+
+
+-- | map a function across all the basic blocks in this code (monadic version)
+--
+mapBlockTopM
+ :: Monad m
+ => (LiveBasicBlock -> m LiveBasicBlock)
+ -> LiveCmmTop -> m LiveCmmTop
+
+mapBlockTopM f cmm@(CmmData{})
+ = return cmm
+
+mapBlockTopM f (CmmProc header label params comps)
+ = do comps' <- mapM (mapBlockCompM f) comps
+ return $ CmmProc header label params comps'
+
+mapBlockCompM f (BasicBlock i blocks)
+ = do blocks' <- mapM f blocks
+ return $ BasicBlock i blocks'
+
+
+-- | Slurp out the list of register conflicts from this top level thing.
+
+slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
+slurpConflicts live
+ = slurpCmm emptyBag live
+
+ where slurpCmm rs CmmData{} = rs
+ slurpCmm rs (CmmProc info _ _ blocks)
+ = foldl' (slurpComp info) rs blocks
+
+ slurpComp info rs (BasicBlock i blocks)
+ = foldl' (slurpBlock info) rs blocks
+
+ slurpBlock info rs (BasicBlock blockId instrs)
+ | LiveInfo _ _ blockLive <- info
+ , Just rsLiveEntry <- lookupUFM blockLive blockId
+ = consBag rsLiveEntry $ slurpLIs rsLiveEntry rs instrs
+
+ slurpLIs rsLive rs [] = consBag rsLive rs
+ slurpLIs rsLive rs (Instr _ Nothing : lis) = slurpLIs rsLive rs lis
+
+ slurpLIs rsLiveEntry rs (li@(Instr _ (Just live)) : lis)
+ = let
+ -- regs that die because they are read for the last time at the start of an instruction
+ -- are not live across it.
+ rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
+
+ -- regs live on entry to the next instruction.
+ -- be careful of orphans, make sure to delete dying regs _after_ unioning
+ -- in the ones that are born here.
+ rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
+ `minusUniqSet` (liveDieWrite live)
+
+ -- orphan vregs are the ones that die in the same instruction they are born in.
+ -- these are likely to be results that are never used, but we still
+ -- need to assign a hreg to them..
+ rsOrphans = intersectUniqSets
+ (liveBorn live)
+ (unionUniqSets (liveDieWrite live) (liveDieRead live))
+
+ --
+ rsConflicts = unionUniqSets rsLiveNext rsOrphans
+
+ in slurpLIs rsLiveNext (consBag rsConflicts rs) lis
+
+
+-- | Strip away liveness information, yielding NatCmmTop
+
+stripLive :: LiveCmmTop -> NatCmmTop
+stripLive live
+ = stripCmm live
+
+ where stripCmm (CmmData sec ds) = CmmData sec ds
+ stripCmm (CmmProc (LiveInfo info _ _) label params comps)
+ = CmmProc info label params (concatMap stripComp comps)
+
+ stripComp (BasicBlock i blocks) = map stripBlock blocks
+ stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs)
+ stripLI (Instr instr _) = instr
+
+
+-- | Slurp out a map of how many times each register was live upon entry to an instruction.
+
+lifetimeCount
+ :: LiveCmmTop
+ -> UniqFM (Reg, Int) -- ^ reg -> (reg, count)
+
+lifetimeCount cmm
+ = countCmm emptyUFM cmm
+ where
+ countCmm fm CmmData{} = fm
+ countCmm fm (CmmProc info _ _ blocks)
+ = foldl' (countComp info) fm blocks
+
+ countComp info fm (BasicBlock i blocks)
+ = foldl' (countBlock info) fm blocks
+
+ countBlock info fm (BasicBlock blockId instrs)
+ | LiveInfo _ _ blockLive <- info
+ , Just rsLiveEntry <- lookupUFM blockLive blockId
+ = countLIs rsLiveEntry fm instrs
+
+ countLIs rsLive fm [] = fm
+ countLIs rsLive fm (Instr _ Nothing : lis) = countLIs rsLive fm lis
+
+ countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
+ = let
+ rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live)
+
+ rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live))
+ `minusUniqSet` (liveDieWrite live)
+
+ add r fm = addToUFM_C
+ (\(r1, l1) (_, l2) -> (r1, l1 + l2))
+ fm r (r, 1)
+
+ fm' = foldUniqSet add fm rsLiveEntry
+ in countLIs rsLiveNext fm' lis
+
+
+-- | Erase Delta instructions.
+
+eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
+eraseDeltasLive cmm
+ = mapBlockTop eraseBlock cmm
+ where
+ isDelta (DELTA _) = True
+ isDelta _ = False
+
+ eraseBlock (BasicBlock id lis)
+ = BasicBlock id
+ $ filter (\(Instr i _) -> not $ isDelta i)
+ $ lis
+
+
+-- | Patch the registers in this code according to this register mapping.
+-- also erase reg -> reg moves when the reg is the same.
+-- also erase reg -> reg moves when the destination dies in this instr.
+
+patchEraseLive
+ :: (Reg -> Reg)
+ -> LiveCmmTop -> LiveCmmTop
+
+patchEraseLive patchF cmm
+ = patchCmm cmm
+ where
+ patchCmm cmm@CmmData{} = cmm
+
+ patchCmm cmm@(CmmProc info label params comps)
+ | LiveInfo static id blockMap <- info
+ = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
+ blockMap' = mapUFM patchRegSet blockMap
+
+ info' = LiveInfo static id blockMap'
+ in CmmProc info' label params $ map patchComp comps
+
+ patchComp (BasicBlock id blocks)
+ = BasicBlock id $ map patchBlock blocks
+
+ patchBlock (BasicBlock id lis)
+ = BasicBlock id $ patchInstrs lis
+
+ patchInstrs [] = []
+ patchInstrs (li : lis)
+
+ | Instr i (Just live) <- li'
+ , Just (r1, r2) <- isRegRegMove i
+ , eatMe r1 r2 live
+ = patchInstrs lis
+
+ | otherwise
+ = li' : patchInstrs lis
+
+ where li' = patchRegsLiveInstr patchF li
+
+ eatMe r1 r2 live
+ -- source and destination regs are the same
+ | r1 == r2 = True
+
+ -- desination reg is never used
+ | elementOfUniqSet r2 (liveBorn live)
+ , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
+ = True
+
+ | otherwise = False
+
+
+-- | Patch registers in this LiveInstr, including the liveness information.
+--
+patchRegsLiveInstr
+ :: (Reg -> Reg)
+ -> LiveInstr -> LiveInstr
+
+patchRegsLiveInstr patchF li
+ = case li of
+ Instr instr Nothing
+ -> Instr (patchRegs instr patchF) Nothing
+
+ Instr instr (Just live)
+ -> Instr
+ (patchRegs instr patchF)
+ (Just live
+ { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
+ liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
+ , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
+ , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
+
+
+---------------------------------------------------------------------------------
+-- Annotate code with register liveness information
+--
+regLiveness
+ :: NatCmmTop
+ -> UniqSM LiveCmmTop
+
+regLiveness cmm@(CmmData sec d)
+ = returnUs $ CmmData sec d
+
+regLiveness cmm@(CmmProc info lbl params [])
+ = returnUs $ CmmProc
+ (LiveInfo info Nothing emptyUFM)
+ lbl params []
+
+regLiveness cmm@(CmmProc info lbl params blocks@(first:rest))
+ = let first_id = blockId first
+ sccs = sccBlocks blocks
+ (ann_sccs, block_live) = computeLiveness sccs
+
+ liveBlocks
+ = map (\scc -> case scc of
+ AcyclicSCC b@(BasicBlock l _) -> BasicBlock l [b]
+ CyclicSCC bs@(BasicBlock l _ : _) -> BasicBlock l bs
+ CyclicSCC []
+ -> panic "RegLiveness.regLiveness: no blocks in scc list")
+ $ ann_sccs
+
+ in returnUs $ CmmProc
+ (LiveInfo info (Just first_id) block_live)
+ lbl params liveBlocks
+
+
+sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
+sccBlocks blocks = stronglyConnComp graph
+ where
+ getOutEdges :: [Instr] -> [BlockId]
+ getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs
+
+ graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
+ | block@(BasicBlock id instrs) <- blocks ]
+
+
+-- -----------------------------------------------------------------------------
+-- Computing liveness
+
+computeLiveness
+ :: [SCC NatBasicBlock]
+ -> ([SCC LiveBasicBlock], -- instructions annotated with list of registers
+ -- which are "dead after this instruction".
+ BlockMap RegSet) -- blocks annontated with set of live registers
+ -- on entry to the block.
+
+ -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
+ -- control to earlier ones only. The SCCs returned are in the *opposite*
+ -- order, which is exactly what we want for the next pass.
+
+computeLiveness sccs
+ = livenessSCCs emptyBlockMap [] sccs
+
+
+livenessSCCs
+ :: BlockMap RegSet
+ -> [SCC LiveBasicBlock] -- accum
+ -> [SCC NatBasicBlock]
+ -> ([SCC LiveBasicBlock], BlockMap RegSet)
+
+livenessSCCs blockmap done [] = (done, blockmap)
+
+livenessSCCs blockmap done (AcyclicSCC block : sccs)
+ = let (blockmap', block') = livenessBlock blockmap block
+ in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
+
+livenessSCCs blockmap done
+ (CyclicSCC blocks : sccs) =
+ livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
+ where (blockmap', blocks')
+ = iterateUntilUnchanged linearLiveness equalBlockMaps
+ blockmap blocks
+
+ iterateUntilUnchanged
+ :: (a -> b -> (a,c)) -> (a -> a -> Bool)
+ -> a -> b
+ -> (a,c)
+
+ iterateUntilUnchanged f eq a b
+ = head $
+ concatMap tail $
+ groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
+ iterate (\(a, _) -> f a b) $
+ (a, error "RegisterAlloc.livenessSCCs")
+
+
+ linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
+ -> (BlockMap RegSet, [LiveBasicBlock])
+ linearLiveness = mapAccumL livenessBlock
+
+ -- probably the least efficient way to compare two
+ -- BlockMaps for equality.
+ equalBlockMaps a b
+ = a' == b'
+ where a' = map f $ ufmToList a
+ b' = map f $ ufmToList b
+ f (key,elt) = (key, uniqSetToList elt)
+
+
+
+-- | Annotate a basic block with register liveness information.
+--
+livenessBlock
+ :: BlockMap RegSet
+ -> NatBasicBlock
+ -> (BlockMap RegSet, LiveBasicBlock)
+
+livenessBlock blockmap block@(BasicBlock block_id instrs)
+ = let
+ (regsLiveOnEntry, instrs1)
+ = livenessBack emptyUniqSet blockmap [] (reverse instrs)
+ blockmap' = addToUFM blockmap block_id regsLiveOnEntry
+
+ instrs2 = livenessForward regsLiveOnEntry instrs1
+
+ output = BasicBlock block_id instrs2
+
+ in ( blockmap', output)
+
+-- | Calculate liveness going forwards,
+-- filling in when regs are born
+
+livenessForward
+ :: RegSet -- regs live on this instr
+ -> [LiveInstr] -> [LiveInstr]
+
+livenessForward rsLiveEntry [] = []
+livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
+ | Nothing <- mLive
+ = li : livenessForward rsLiveEntry lis
+
+ | Just live <- mLive
+ , RU read written <- regUsage instr
+ = let
+ -- Regs that are written to but weren't live on entry to this instruction
+ -- are recorded as being born here.
+ rsBorn = mkUniqSet
+ $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
+
+ rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn)
+ `minusUniqSet` (liveDieRead live)
+ `minusUniqSet` (liveDieWrite live)
+
+ in Instr instr (Just live { liveBorn = rsBorn })
+ : livenessForward rsLiveNext lis
+
+
+-- | Calculate liveness going backwards,
+-- filling in when regs die, and what regs are live across each instruction
+
+livenessBack
+ :: RegSet -- regs live on this instr
+ -> BlockMap RegSet -- regs live on entry to other BBs
+ -> [LiveInstr] -- instructions (accum)
+ -> [Instr] -- instructions
+ -> (RegSet, [LiveInstr])
+
+livenessBack liveregs blockmap done [] = (liveregs, done)
+
+livenessBack liveregs blockmap acc (instr : instrs)
+ = let (liveregs', instr') = liveness1 liveregs blockmap instr
+ in livenessBack liveregs' blockmap (instr' : acc) instrs
+
+-- don't bother tagging comments or deltas with liveness
+liveness1 liveregs blockmap (instr@COMMENT{})
+ = (liveregs, Instr instr Nothing)
+
+liveness1 liveregs blockmap (instr@DELTA{})
+ = (liveregs, Instr instr Nothing)
+
+liveness1 liveregs blockmap instr
+
+ | not_a_branch
+ = (liveregs1, Instr instr
+ (Just $ Liveness
+ { liveBorn = emptyUniqSet
+ , liveDieRead = mkUniqSet r_dying
+ , liveDieWrite = mkUniqSet w_dying }))
+
+ | otherwise
+ = (liveregs_br, Instr instr
+ (Just $ Liveness
+ { liveBorn = emptyUniqSet
+ , liveDieRead = mkUniqSet r_dying_br
+ , liveDieWrite = mkUniqSet w_dying }))
+
+ where
+ RU read written = regUsage instr
+
+ -- registers that were written here are dead going backwards.
+ -- registers that were read here are live going backwards.
+ liveregs1 = (liveregs `delListFromUniqSet` written)
+ `addListToUniqSet` read
+
+ -- registers that are not live beyond this point, are recorded
+ -- as dying here.
+ r_dying = [ reg | reg <- read, reg `notElem` written,
+ not (elementOfUniqSet reg liveregs) ]
+
+ w_dying = [ reg | reg <- written,
+ not (elementOfUniqSet reg liveregs) ]
+
+ -- union in the live regs from all the jump destinations of this
+ -- instruction.
+ targets = jumpDests instr [] -- where we go from here
+ not_a_branch = null targets
+
+ targetLiveRegs target
+ = case lookupUFM blockmap target of
+ Just ra -> ra
+ Nothing -> emptyBlockMap
+
+ live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
+
+ liveregs_br = liveregs1 `unionUniqSets` live_from_branch
+
+ -- registers that are live only in the branch targets should
+ -- be listed as dying here.
+ live_branch_only = live_from_branch `minusUniqSet` liveregs
+ r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`
+ live_branch_only)
+
+
+
+
--- /dev/null
+
+module RegSpill (
+ regSpill
+)
+
+where
+
+#include "HsVersions.h"
+
+import RegLiveness
+import RegAllocInfo
+import MachRegs
+import MachInstrs
+import Cmm
+
+import Unique
+import UniqFM
+import UniqSet
+import UniqSupply
+import Outputable
+
+import Data.List
+import Data.Maybe
+
+
+-- | Spill all these virtual regs to memory
+-- TODO: see if we can split some of the live ranges instead of just globally
+-- spilling the virtual reg.
+--
+-- TODO: On ciscy x86 and x86_64 we don't nessesarally have to add a mov instruction
+-- when making spills. If an instr is using a spilled virtual we may be able to
+-- address the spill slot directly.
+--
+regSpill
+ :: [LiveCmmTop] -- ^ the code
+ -> UniqSet Int -- ^ available stack slots
+ -> UniqSet Reg -- ^ the regs to spill
+ -> UniqSM
+ ([LiveCmmTop] -- ^ code will spill instructions
+ , UniqSet Int) -- ^ left over slots
+
+regSpill code slotsFree regs
+
+ -- not enough slots to spill these regs
+ | sizeUniqSet slotsFree < sizeUniqSet regs
+ = pprPanic "regSpill: out of spill slots!"
+ ( text " regs to spill = " <> ppr (sizeUniqSet regs)
+ $$ text " slots left = " <> ppr (sizeUniqSet slotsFree))
+
+ | otherwise
+ = do
+ -- allocate a slot for each of the spilled regs
+ let slots = take (sizeUniqSet regs) $ uniqSetToList slotsFree
+ let regSlotMap = listToUFM
+ $ zip (uniqSetToList regs) slots
+
+ -- grab the unique supply from the monad
+ us <- getUs
+
+ -- run the spiller on all the blocks
+ let (# code', _ #) =
+ runSpill (mapM (mapBlockTopM (regSpill_block regSlotMap)) code)
+ (initSpillS us)
+
+ return ( code'
+ , minusUniqSet slotsFree (mkUniqSet slots) )
+
+
+regSpill_block regSlotMap (BasicBlock i instrs)
+ = do instrss' <- mapM (regSpill_instr regSlotMap) instrs
+ return $ BasicBlock i (concat instrss')
+
+
+regSpill_instr _ li@(Instr (DELTA delta) _)
+ = do
+ setDelta delta
+ return [li]
+
+regSpill_instr _ li@(Instr _ Nothing)
+ = do return [li]
+
+
+regSpill_instr regSlotMap
+ (Instr instr (Just live))
+ = do
+ -- work out which regs are read and written in this instr
+ let RU rlRead rlWritten = regUsage instr
+
+ -- sometimes a register is listed as being read more than once,
+ -- nub this so we don't end up inserting two lots of spill code.
+ let rsRead_ = nub rlRead
+ let rsWritten_ = nub rlWritten
+
+ -- if a reg is modified, it appears in both lists, want to undo this..
+ let rsRead = rsRead_ \\ rsWritten_
+ let rsWritten = rsWritten_ \\ rsRead_
+ let rsModify = intersect rsRead_ rsWritten_
+
+ -- work out if any of the regs being used are currently being spilled.
+ let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead
+ let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten
+ let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify
+
+ -- rewrite the instr and work out spill code.
+ (instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead
+ (instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten
+ (instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
+
+ let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3)
+ let prefixes = concat mPrefixes
+ let postfixes = concat mPostfixes
+
+ -- final code
+ let instrs' = map (\i -> Instr i Nothing) prefixes
+ ++ [ Instr instr3 Nothing ]
+ ++ map (\i -> Instr i Nothing) postfixes
+
+ return
+{- $ pprTrace "* regSpill_instr spill"
+ ( text "instr = " <> ppr instr
+ $$ text "read = " <> ppr rsSpillRead
+ $$ text "write = " <> ppr rsSpillWritten
+ $$ text "mod = " <> ppr rsSpillModify
+ $$ text "-- out"
+ $$ (vcat $ map ppr instrs')
+ $$ text " ")
+-}
+ $ instrs'
+
+
+spillRead regSlotMap instr reg
+ | Just slot <- lookupUFM regSlotMap reg
+ = do delta <- getDelta
+ (instr', nReg) <- patchInstr reg instr
+
+ let pre = [ COMMENT FSLIT("spill read")
+ , mkLoadInstr nReg delta slot ]
+
+ return ( instr', (pre, []))
+
+ | otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg"
+
+spillWrite regSlotMap instr reg
+ | Just slot <- lookupUFM regSlotMap reg
+ = do delta <- getDelta
+ (instr', nReg) <- patchInstr reg instr
+
+ let post = [ COMMENT FSLIT("spill write")
+ , mkSpillInstr nReg delta slot ]
+
+ return ( instr', ([], post))
+
+ | otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg"
+
+spillModify regSlotMap instr reg
+ | Just slot <- lookupUFM regSlotMap reg
+ = do delta <- getDelta
+ (instr', nReg) <- patchInstr reg instr
+
+ let pre = [ COMMENT FSLIT("spill mod load")
+ , mkLoadInstr nReg delta slot ]
+
+ let post = [ COMMENT FSLIT("spill mod write")
+ , mkSpillInstr nReg delta slot ]
+
+ return ( instr', (pre, post))
+
+ | otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg"
+
+
+-- | rewrite uses of this virtual reg in an instr to use a different virtual reg
+patchInstr :: Reg -> Instr -> SpillM (Instr, Reg)
+patchInstr reg instr
+ = do nUnique <- newUnique
+ let nReg = renameVirtualReg nUnique reg
+ let instr' = patchReg1 reg nReg instr
+ return (instr', nReg)
+
+patchReg1 :: Reg -> Reg -> Instr -> Instr
+patchReg1 old new instr
+ = let patchF r
+ | r == old = new
+ | otherwise = r
+ in patchRegs instr patchF
+
+
+-------------------------------------------------------------------------------------------
+-- Spiller monad
+
+data SpillS
+ = SpillS
+ { stateDelta :: Int
+ , stateUS :: UniqSupply }
+
+initSpillS uniqueSupply
+ = SpillS
+ { stateDelta = 0
+ , stateUS = uniqueSupply }
+
+newtype SpillM a
+ = SpillM
+ { runSpill :: SpillS -> (# a, SpillS #) }
+
+instance Monad SpillM where
+ return x = SpillM $ \s -> (# x, s #)
+
+ m >>= n = SpillM $ \s ->
+ case runSpill m s of
+ (# r, s' #) -> runSpill (n r) s'
+
+setDelta :: Int -> SpillM ()
+setDelta delta
+ = SpillM $ \s -> (# (), s { stateDelta = delta } #)
+
+getDelta :: SpillM Int
+getDelta = SpillM $ \s -> (# stateDelta s, s #)
+
+newUnique :: SpillM Unique
+newUnique
+ = SpillM $ \s
+ -> case splitUniqSupply (stateUS s) of
+ (us1, us2)
+ -> (# uniqFromSupply us1
+ , s { stateUS = us2 } #)
+
+mapAccumLM _ s [] = return (s, [])
+mapAccumLM f s (x:xs)
+ = do
+ (s1, x') <- f s x
+ (s2, xs') <- mapAccumLM f s1 xs
+ return (s2, x' : xs')
+
+
--- /dev/null
+
+module State where
+
+newtype State s a
+ = State
+ { runState :: s -> (# a, s #) }
+
+instance Monad (State s) where
+ return x = State $ \s -> (# x, s #)
+ m >>= n = State $ \s ->
+ case runState m s of
+ (# r, s' #) -> runState (n r) s'
+
+get :: State s s
+get = State $ \s -> (# s, s #)
+
+put :: s -> State s ()
+put s' = State $ \s -> (# (), s' #)
+
+modify :: (s -> s) -> State s ()
+modify f = State $ \s -> (# (), f s #)
+
+evalState :: State s a -> s -> a
+evalState s i
+ = case runState s i of
+ (# a, s' #) -> a
+
+execState :: State s a -> s -> s
+execState s i
+ = case runState s i of
+ (# a, s' #) -> s'
projects / ghc-hetmet.git / commitdiff