From: Ian Lynagh Date: Tue, 31 May 2011 18:02:52 +0000 (+0100) Subject: Remove CPP from nativeGen/RegAlloc/Linear/FreeRegs.hs X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=3c2a7f3515ca15cdebb6242967f89e633cb59494 Remove CPP from nativeGen/RegAlloc/Linear/FreeRegs.hs Fixes more failures on arches without an NCG --- diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index c7ea591..ae91b62 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -424,7 +424,7 @@ cmmNativeGen dflags ncgImpl us cmm count = {-# SCC "RegAlloc" #-} initUs usLive $ liftM unzip - $ mapUs Linear.regAlloc withLiveness + $ mapUs (Linear.regAlloc dflags) withLiveness dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs index fc8d4ed..432acdf 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Base.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs @@ -18,7 +18,6 @@ module RegAlloc.Linear.Base ( where -import RegAlloc.Linear.FreeRegs import RegAlloc.Linear.StackMap import RegAlloc.Liveness import Reg @@ -34,8 +33,8 @@ import UniqSupply -- target a particular label. We have to insert fixup code to make -- the register assignments from the different sources match up. -- -type BlockAssignment - = BlockMap (FreeRegs, RegMap Loc) +type BlockAssignment freeRegs + = BlockMap (freeRegs, RegMap Loc) -- | Where a vreg is currently stored @@ -107,7 +106,7 @@ data RA_State freeRegs { -- | the current mapping from basic blocks to -- the register assignments at the beginning of that block. - ra_blockassig :: BlockAssignment + ra_blockassig :: BlockAssignment freeRegs -- | free machine registers , ra_freeregs :: !freeRegs diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index b357160..b442d06 100644 --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -1,18 +1,19 @@ 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* @@ -25,21 +26,48 @@ where -- 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" diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index 6a62f07..e6a078a 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -1,5 +1,3 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} - -- | Handles joining of a jump instruction to its targets. @@ -35,14 +33,14 @@ import UniqSet -- 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. @@ -57,7 +55,7 @@ joinToTargets block_live id instr ----- 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. @@ -68,7 +66,7 @@ joinToTargets' -> [BlockId] -- ^ branch destinations still to consider. - -> RegM FreeRegs ( [NatBasicBlock instr] + -> RegM freeRegs ( [NatBasicBlock instr] , instr) -- no more targets to consider. all done. @@ -109,13 +107,24 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) -- this is the first time we jumped to this block. +joinToTargets_first :: (FR freeRegs, Instruction instr) + => 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) @@ -124,6 +133,16 @@ joinToTargets_first block_live new_blocks block_id instr dest dests -- 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 @@ -262,7 +281,7 @@ expandNode vreg src dst -- 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 @@ -317,7 +336,7 @@ makeMove -> 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) diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index ba8cdce..b91c2d0 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -95,6 +95,9 @@ import RegAlloc.Linear.StackMap 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 @@ -104,11 +107,13 @@ import BlockId 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 @@ -123,24 +128,25 @@ import Control.Monad -- 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 @@ -151,7 +157,7 @@ regAlloc (CmmProc static lbl sccs) , Just stats) -- bogus. to make non-exhaustive match warning go away. -regAlloc (CmmProc _ _ _) +regAlloc _ (CmmProc _ _ _) = panic "RegAllocLinear.regAlloc: no match" @@ -165,25 +171,43 @@ regAlloc (CmmProc _ _ _) -- 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 @@ -213,14 +237,14 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) 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 @@ -257,10 +281,10 @@ process first_id block_live (b@(BasicBlock id _) : blocks) -- | 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 @@ -271,7 +295,7 @@ processBlock block_live (BasicBlock id instrs) -- | 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 @@ -280,7 +304,7 @@ initBlock id Nothing -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ()) - setFreeRegsR initFreeRegs + setFreeRegsR frInitFreeRegs setAssigR emptyRegMap -- load info about register assignments leading into this block. @@ -291,14 +315,14 @@ initBlock id -- | 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. @@ -319,12 +343,12 @@ linearRA block_live accInstr accFixups id (instr:instrs) -- | 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 @@ -382,14 +406,14 @@ raInsn _ _ _ instr = 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 -> @@ -486,7 +510,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = -- ----------------------------------------------------------------------------- -- releaseRegs -releaseRegs :: [Reg] -> RegM FreeRegs () +releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () releaseRegs regs = do assig <- getAssigR free <- getFreeRegsR @@ -494,11 +518,11 @@ releaseRegs regs = do 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 @@ -524,7 +548,7 @@ saveClobberedTemps :: (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 [] _ @@ -563,14 +587,14 @@ saveClobberedTemps clobbered dying -- | 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) @@ -613,13 +637,13 @@ data SpillLoc = ReadMem StackSlot -- reading from register only in memory -- 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) @@ -657,7 +681,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) -- 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] @@ -666,11 +690,11 @@ allocRegsAndSpill_spill :: (Instruction instr, Outputable 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 @@ -679,7 +703,7 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc 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 @@ -748,7 +772,7 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc [ 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 @@ -767,7 +791,7 @@ loadTemp -> 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 diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs index 7793fee..05db9de 100644 --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -32,7 +32,6 @@ where import RegAlloc.Linear.Stats import RegAlloc.Linear.StackMap import RegAlloc.Linear.Base -import RegAlloc.Linear.FreeRegs import RegAlloc.Liveness import Instruction import Reg @@ -48,13 +47,13 @@ instance Monad (RegM freeRegs) where -- | 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 @@ -76,14 +75,14 @@ runR block_assig freeregs assig stack us 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 @@ -93,49 +92,49 @@ spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> 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}, () #)