module RegAlloc.Linear.FreeRegs (
- FreeRegs(),
- noFreeRegs,
- releaseReg,
- initFreeRegs,
- getFreeRegs,
- allocateReg,
- maxSpillSlots
+ FR(..),
+ maxSpillSlots
)
#include "HsVersions.h"
where
+import Reg
+import RegClass
+
+import Panic
+import Platform
+
-- -----------------------------------------------------------------------------
-- The free register set
-- This needs to be *efficient*
-- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
-- allocateReg f r = filter (/= r) f
+import qualified RegAlloc.Linear.PPC.FreeRegs as PPC
+import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC
+import qualified RegAlloc.Linear.X86.FreeRegs as X86
+
+import qualified PPC.Instr
+import qualified SPARC.Instr
+import qualified X86.Instr
+
+class Show freeRegs => FR freeRegs where
+ frAllocateReg :: RealReg -> freeRegs -> freeRegs
+ frGetFreeRegs :: RegClass -> freeRegs -> [RealReg]
+ frInitFreeRegs :: freeRegs
+ frReleaseReg :: RealReg -> freeRegs -> freeRegs
-#if defined(powerpc_TARGET_ARCH)
-import RegAlloc.Linear.PPC.FreeRegs
-import PPC.Instr (maxSpillSlots)
+instance FR X86.FreeRegs where
+ frAllocateReg = X86.allocateReg
+ frGetFreeRegs = X86.getFreeRegs
+ frInitFreeRegs = X86.initFreeRegs
+ frReleaseReg = X86.releaseReg
-#elif defined(sparc_TARGET_ARCH)
-import RegAlloc.Linear.SPARC.FreeRegs
-import SPARC.Instr (maxSpillSlots)
+instance FR PPC.FreeRegs where
+ frAllocateReg = PPC.allocateReg
+ frGetFreeRegs = PPC.getFreeRegs
+ frInitFreeRegs = PPC.initFreeRegs
+ frReleaseReg = PPC.releaseReg
-#elif defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH)
-import RegAlloc.Linear.X86.FreeRegs
-import X86.Instr (maxSpillSlots)
+instance FR SPARC.FreeRegs where
+ frAllocateReg = SPARC.allocateReg
+ frGetFreeRegs = SPARC.getFreeRegs
+ frInitFreeRegs = SPARC.initFreeRegs
+ frReleaseReg = SPARC.releaseReg
-#else
-#error "RegAlloc.Linear.FreeRegs not defined for this architecture."
+-- TODO: We shouldn't be using defaultTargetPlatform here.
+-- We should be passing DynFlags in instead, and looking at
+-- its targetPlatform.
-#endif
+maxSpillSlots :: Int
+maxSpillSlots = case platformArch defaultTargetPlatform of
+ ArchX86 -> X86.Instr.maxSpillSlots
+ ArchX86_64 -> X86.Instr.maxSpillSlots
+ ArchPPC -> PPC.Instr.maxSpillSlots
+ ArchSPARC -> SPARC.Instr.maxSpillSlots
+ ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64"
+ ArchUnknown -> panic "maxSpillSlots ArchUnknown"
-{-# OPTIONS -fno-warn-missing-signatures #-}
-
-- | Handles joining of a jump instruction to its targets.
-- vregs are in the correct regs for its destination.
--
joinToTargets
- :: Instruction 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.
-> BlockId -- ^ id of the current block
-> instr -- ^ branch instr on the end of the source block.
- -> RegM FreeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code.
+ -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code.
, instr) -- the original branch instruction, but maybe patched to jump
-- to a fixup block first.
-----
joinToTargets'
- :: Instruction 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.
-> [BlockId] -- ^ branch destinations still to consider.
- -> RegM FreeRegs ( [NatBasicBlock instr]
+ -> RegM freeRegs ( [NatBasicBlock instr]
, instr)
-- no more targets to consider. all done.
-- this is the first time we jumped to this block.
+joinToTargets_first :: (FR freeRegs, Instruction instr)
+ => BlockMap RegSet
+ -> [NatBasicBlock instr]
+ -> BlockId
+ -> instr
+ -> BlockId
+ -> [BlockId]
+ -> BlockAssignment freeRegs
+ -> RegMap Loc
+ -> [RealReg]
+ -> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets_first block_live new_blocks block_id instr dest dests
block_assig src_assig
- (to_free :: [RealReg])
+ to_free
= do -- free up the regs that are not live on entry to this block.
freeregs <- getFreeRegsR
- let freeregs' = foldr releaseReg freeregs to_free
+ let freeregs' = foldr frReleaseReg freeregs to_free
-- remember the current assignment on entry to this block.
setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig)
-- we've jumped to this block before
+joinToTargets_again :: (Instruction instr, FR freeRegs)
+ => BlockMap RegSet
+ -> [NatBasicBlock instr]
+ -> BlockId
+ -> instr
+ -> BlockId
+ -> [BlockId]
+ -> UniqFM Loc
+ -> UniqFM Loc
+ -> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets_again
block_live new_blocks block_id instr dest dests
src_assig dest_assig
--
handleComponent
:: Instruction instr
- => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM FreeRegs [instr]
+ => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [instr]
-- If the graph is acyclic then we won't get the swapping problem below.
-- In this case we can just do the moves directly, and avoid having to
-> Unique -- ^ unique of the vreg that we're moving.
-> Loc -- ^ source location.
-> Loc -- ^ destination location.
- -> RegM FreeRegs instr -- ^ move instruction.
+ -> RegM freeRegs instr -- ^ move instruction.
makeMove _ vreg (InReg src) (InReg dst)
= do recordSpill (SpillJoinRR vreg)
import RegAlloc.Linear.FreeRegs
import RegAlloc.Linear.Stats
import RegAlloc.Linear.JoinToTargets
+import qualified RegAlloc.Linear.PPC.FreeRegs as PPC
+import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC
+import qualified RegAlloc.Linear.X86.FreeRegs as X86
import TargetReg
import RegAlloc.Liveness
import Instruction
import OldCmm hiding (RegSet)
import Digraph
+import DynFlags
import Unique
import UniqSet
import UniqFM
import UniqSupply
import Outputable
+import Platform
import Data.Maybe
import Data.List
-- Allocate registers
regAlloc
:: (Outputable instr, Instruction instr)
- => LiveCmmTop instr
+ => DynFlags
+ -> LiveCmmTop instr
-> UniqSM (NatCmmTop instr, Maybe RegAllocStats)
-regAlloc (CmmData sec d)
+regAlloc _ (CmmData sec d)
= return
( CmmData sec d
, Nothing )
-regAlloc (CmmProc (LiveInfo info _ _ _) lbl [])
+regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl [])
= return ( CmmProc info lbl (ListGraph [])
, Nothing )
-regAlloc (CmmProc static lbl sccs)
+regAlloc dflags (CmmProc static lbl sccs)
| LiveInfo info (Just first_id) (Just block_live) _ <- static
= do
-- do register allocation on each component.
(final_blocks, stats)
- <- linearRegAlloc first_id block_live sccs
+ <- linearRegAlloc dflags first_id block_live sccs
-- make sure the block that was first in the input list
-- stays at the front of the output
, Just stats)
-- bogus. to make non-exhaustive match warning go away.
-regAlloc (CmmProc _ _ _)
+regAlloc _ (CmmProc _ _ _)
= panic "RegAllocLinear.regAlloc: no match"
--
linearRegAlloc
:: (Outputable instr, Instruction instr)
- => BlockId -- ^ the first block
+ => DynFlags
+ -> BlockId -- ^ the first block
-> BlockMap RegSet -- ^ live regs on entry to each basic block
-> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
-> UniqSM ([NatBasicBlock instr], RegAllocStats)
-linearRegAlloc first_id block_live sccs
+linearRegAlloc dflags first_id block_live sccs
+ = case platformArch $ targetPlatform dflags of
+ ArchX86 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs
+ ArchX86_64 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs
+ ArchSPARC -> linearRegAlloc' (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs
+ ArchPPC -> linearRegAlloc' (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs
+ ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64"
+ ArchUnknown -> panic "linearRegAlloc ArchUnknown"
+
+linearRegAlloc'
+ :: (FR freeRegs, Outputable instr, Instruction instr)
+ => freeRegs
+ -> BlockId -- ^ the first block
+ -> BlockMap RegSet -- ^ live regs on entry to each basic block
+ -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
+ -> UniqSM ([NatBasicBlock instr], RegAllocStats)
+
+linearRegAlloc' initFreeRegs first_id block_live sccs
= do us <- getUs
let (_, _, stats, blocks) =
runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
- $ linearRA_SCCs first_id block_live [] sccs
-
+ $ linearRA_SCCs first_id block_live [] sccs
return (blocks, stats)
-linearRA_SCCs :: (Instruction instr, Outputable instr)
+
+linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)
=> BlockId
-> BlockMap RegSet
-> [NatBasicBlock instr]
-> [SCC (LiveBasicBlock instr)]
- -> RegM FreeRegs [NatBasicBlock instr]
+ -> RegM freeRegs [NatBasicBlock instr]
linearRA_SCCs _ _ blocksAcc []
= return $ reverse blocksAcc
more sanity checking to guard against this eventuality.
-}
-process :: (Instruction instr, Outputable instr)
+process :: (FR freeRegs, Instruction instr, Outputable instr)
=> BlockId
-> BlockMap RegSet
-> [GenBasicBlock (LiveInstr instr)]
-> [GenBasicBlock (LiveInstr instr)]
-> [[NatBasicBlock instr]]
-> Bool
- -> RegM FreeRegs [[NatBasicBlock instr]]
+ -> RegM freeRegs [[NatBasicBlock instr]]
process _ _ [] [] accum _
= return $ reverse accum
-- | Do register allocation on this basic block
--
processBlock
- :: (Outputable instr, Instruction instr)
+ :: (FR freeRegs, Outputable instr, Instruction instr)
=> BlockMap RegSet -- ^ live regs on entry to each basic block
-> LiveBasicBlock instr -- ^ block to do register allocation on
- -> RegM FreeRegs [NatBasicBlock instr] -- ^ block with registers allocated
+ -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated
processBlock block_live (BasicBlock id instrs)
= do initBlock id
-- | Load the freeregs and current reg assignment into the RegM state
-- for the basic block with this BlockId.
-initBlock :: BlockId -> RegM FreeRegs ()
+initBlock :: FR freeRegs => BlockId -> RegM freeRegs ()
initBlock id
= do block_assig <- getBlockAssigR
case mapLookup id block_assig of
Nothing
-> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
- setFreeRegsR initFreeRegs
+ setFreeRegsR frInitFreeRegs
setAssigR emptyRegMap
-- load info about register assignments leading into this block.
-- | Do allocation for a sequence of instructions.
linearRA
- :: (Outputable instr, Instruction instr)
+ :: (FR freeRegs, Outputable instr, Instruction instr)
=> BlockMap RegSet -- ^ map of what vregs are live on entry to each block.
-> [instr] -- ^ accumulator for instructions already processed.
-> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code.
-> BlockId -- ^ id of the current block, for debugging.
-> [LiveInstr instr] -- ^ liveness annotated instructions in this block.
- -> RegM FreeRegs
+ -> RegM freeRegs
( [instr] -- instructions after register allocation
, [NatBasicBlock instr]) -- fresh blocks of fixup code.
-- | Do allocation for a single instruction.
raInsn
- :: (Outputable instr, Instruction instr)
+ :: (FR freeRegs, Outputable instr, Instruction instr)
=> BlockMap RegSet -- ^ map of what vregs are love on entry to each block.
-> [instr] -- ^ accumulator for instructions already processed.
-> BlockId -- ^ the id of the current block, for debugging
-> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info.
- -> RegM FreeRegs
+ -> RegM freeRegs
( [instr] -- new instructions
, [NatBasicBlock instr]) -- extra fixup blocks
= pprPanic "raInsn" (text "no match for:" <> ppr instr)
-genRaInsn :: (Instruction instr, Outputable instr)
+genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr)
=> BlockMap RegSet
-> [instr]
-> BlockId
-> instr
-> [Reg]
-> [Reg]
- -> RegM FreeRegs ([instr], [NatBasicBlock instr])
+ -> RegM freeRegs ([instr], [NatBasicBlock instr])
genRaInsn block_live new_instrs block_id instr r_dying w_dying =
case regUsageOfInstr instr of { RU read written ->
-- -----------------------------------------------------------------------------
-- releaseRegs
-releaseRegs :: [Reg] -> RegM FreeRegs ()
+releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
releaseRegs regs = do
assig <- getAssigR
free <- getFreeRegsR
where
loop _ free _ | free `seq` False = undefined
loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
- loop assig free (RegReal rr : rs) = loop assig (releaseReg rr free) rs
+ loop assig free (RegReal rr : rs) = loop assig (frReleaseReg rr free) rs
loop assig free (r:rs) =
case lookupUFM assig r of
- Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
- Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
+ Just (InBoth real _) -> loop (delFromUFM assig r) (frReleaseReg real free) rs
+ Just (InReg real) -> loop (delFromUFM assig r) (frReleaseReg real free) rs
_other -> loop (delFromUFM assig r) free rs
:: (Outputable instr, Instruction instr)
=> [RealReg] -- real registers clobbered by this instruction
-> [Reg] -- registers which are no longer live after this insn
- -> RegM FreeRegs [instr] -- return: instructions to spill any temps that will
+ -> RegM freeRegs [instr] -- return: instructions to spill any temps that will
-- be clobbered.
saveClobberedTemps [] _
-- | Mark all these real regs as allocated,
-- and kick out their vreg assignments.
--
-clobberRegs :: [RealReg] -> RegM FreeRegs ()
+clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
clobberRegs []
= return ()
clobberRegs clobbered
= do
freeregs <- getFreeRegsR
- setFreeRegsR $! foldr allocateReg freeregs clobbered
+ setFreeRegsR $! foldr frAllocateReg freeregs clobbered
assig <- getAssigR
setAssigR $! clobber assig (ufmToList assig)
-- the list of free registers and free stack slots.
allocateRegsAndSpill
- :: (Outputable instr, Instruction instr)
+ :: (FR freeRegs, Outputable instr, Instruction instr)
=> Bool -- True <=> reading (load up spilled regs)
-> [VirtualReg] -- don't push these out
-> [instr] -- spill insns
-> [RealReg] -- real registers allocated (accum.)
-> [VirtualReg] -- temps to allocate
- -> RegM FreeRegs ( [instr] , [RealReg])
+ -> RegM freeRegs ( [instr] , [RealReg])
allocateRegsAndSpill _ _ spills alloc []
= return (spills, reverse alloc)
-- 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 :: (Instruction instr, Outputable instr)
+allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)
=> Bool
-> [VirtualReg]
-> [instr]
-> [VirtualReg]
-> UniqFM Loc
-> SpillLoc
- -> RegM FreeRegs ([instr], [RealReg])
+ -> RegM freeRegs ([instr], [RealReg])
allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
= do
freeRegs <- getFreeRegsR
- let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs
+ let freeRegs_thisClass = frGetFreeRegs (classOfVirtualReg r) freeRegs
case freeRegs_thisClass of
do spills' <- loadTemp r spill_loc my_reg spills
setAssigR (addToUFM assig r $! newLocation spill_loc my_reg)
- setFreeRegsR $ allocateReg my_reg freeRegs
+ setFreeRegsR $ frAllocateReg my_reg freeRegs
allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
[ text "allocating vreg: " <> text (show r)
, text "assignment: " <> text (show $ ufmToList assig)
, text "freeRegs: " <> text (show freeRegs)
- , text "initFreeRegs: " <> text (show initFreeRegs) ]
+ , text "initFreeRegs: " <> text (show (frInitFreeRegs `asTypeOf` freeRegs)) ]
result
-> SpillLoc -- the current location of this temp
-> RealReg -- the hreg to load the temp into
-> [instr]
- -> RegM FreeRegs [instr]
+ -> RegM freeRegs [instr]
loadTemp vreg (ReadMem slot) hreg spills
= do
import RegAlloc.Linear.Stats
import RegAlloc.Linear.StackMap
import RegAlloc.Linear.Base
-import RegAlloc.Linear.FreeRegs
import RegAlloc.Liveness
import Instruction
import Reg
-- | Run a computation in the RegM register allocator monad.
-runR :: BlockAssignment
- -> FreeRegs
+runR :: BlockAssignment freeRegs
+ -> freeRegs
-> RegMap Loc
-> StackMap
-> UniqSupply
- -> RegM FreeRegs a
- -> (BlockAssignment, StackMap, RegAllocStats, a)
+ -> RegM freeRegs a
+ -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
runR block_assig freeregs assig stack us thing =
case unReg thing
-- | Make register allocator stats from its final state.
-makeRAStats :: RA_State FreeRegs -> RegAllocStats
+makeRAStats :: RA_State freeRegs -> RegAllocStats
makeRAStats state
= RegAllocStats
{ ra_spillInstrs = binSpillReasons (ra_spills state) }
spillR :: Instruction instr
- => Reg -> Unique -> RegM FreeRegs (instr, Int)
+ => Reg -> Unique -> RegM freeRegs (instr, Int)
spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
let (stack',slot) = getStackSlotFor stack temp
loadR :: Instruction instr
- => Reg -> Int -> RegM FreeRegs instr
+ => Reg -> Int -> RegM freeRegs instr
loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
(# s, mkLoadInstr reg delta slot #)
-getFreeRegsR :: RegM FreeRegs FreeRegs
+getFreeRegsR :: RegM freeRegs freeRegs
getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
(# s, freeregs #)
-setFreeRegsR :: FreeRegs -> RegM FreeRegs ()
+setFreeRegsR :: freeRegs -> RegM freeRegs ()
setFreeRegsR regs = RegM $ \ s ->
(# s{ra_freeregs = regs}, () #)
-getAssigR :: RegM FreeRegs (RegMap Loc)
+getAssigR :: RegM freeRegs (RegMap Loc)
getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
(# s, assig #)
-setAssigR :: RegMap Loc -> RegM FreeRegs ()
+setAssigR :: RegMap Loc -> RegM freeRegs ()
setAssigR assig = RegM $ \ s ->
(# s{ra_assig=assig}, () #)
-getBlockAssigR :: RegM FreeRegs BlockAssignment
+getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
(# s, assig #)
-setBlockAssigR :: BlockAssignment -> RegM FreeRegs ()
+setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
setBlockAssigR assig = RegM $ \ s ->
(# s{ra_blockassig = assig}, () #)
-setDeltaR :: Int -> RegM FreeRegs ()
+setDeltaR :: Int -> RegM freeRegs ()
setDeltaR n = RegM $ \ s ->
(# s{ra_delta = n}, () #)
-getDeltaR :: RegM FreeRegs Int
+getDeltaR :: RegM freeRegs Int
getDeltaR = RegM $ \s -> (# s, ra_delta s #)
-getUniqueR :: RegM FreeRegs Unique
+getUniqueR :: RegM freeRegs Unique
getUniqueR = RegM $ \s ->
case takeUniqFromSupply (ra_us s) of
(uniq, us) -> (# s{ra_us = us}, uniq #)
-- | Record that a spill instruction was inserted, for profiling.
-recordSpill :: SpillReason -> RegM FreeRegs ()
+recordSpill :: SpillReason -> RegM freeRegs ()
recordSpill spill
= RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)