X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FLinear%2FMain.hs;h=b91c2d0269e597ef2c919344fc9da72a6f046289;hb=HEAD;hp=1e904aed22786c4e3eb2319f3efbd763d96023e7;hpb=0af06ed99ed56341adfdda4a92a0a36678780109;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 1e904ae..b91c2d0 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- -- The register allocator @@ -96,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 @@ -105,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 @@ -124,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 @@ -152,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" @@ -166,19 +171,44 @@ 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 :: (FR freeRegs, Instruction instr, Outputable instr) + => BlockId + -> BlockMap RegSet + -> [NatBasicBlock instr] + -> [SCC (LiveBasicBlock instr)] + -> RegM freeRegs [NatBasicBlock instr] + linearRA_SCCs _ _ blocksAcc [] = return $ reverse blocksAcc @@ -207,6 +237,15 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) more sanity checking to guard against this eventuality. -} +process :: (FR freeRegs, Instruction instr, Outputable instr) + => BlockId + -> BlockMap RegSet + -> [GenBasicBlock (LiveInstr instr)] + -> [GenBasicBlock (LiveInstr instr)] + -> [[NatBasicBlock instr]] + -> Bool + -> RegM freeRegs [[NatBasicBlock instr]] + process _ _ [] [] accum _ = return $ reverse accum @@ -242,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 [NatBasicBlock instr] -- ^ block with registers allocated + -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated processBlock block_live (BasicBlock id instrs) = do initBlock id @@ -256,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 () +initBlock :: FR freeRegs => BlockId -> RegM freeRegs () initBlock id = do block_assig <- getBlockAssigR case mapLookup id block_assig of @@ -265,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. @@ -276,14 +315,15 @@ 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 ( [instr] -- instructions after register allocation + -> RegM freeRegs + ( [instr] -- instructions after register allocation , [NatBasicBlock instr]) -- fresh blocks of fixup code. @@ -303,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 + -> RegM freeRegs ( [instr] -- new instructions , [NatBasicBlock instr]) -- extra fixup blocks @@ -366,7 +406,14 @@ raInsn _ _ _ instr = pprPanic "raInsn" (text "no match for:" <> ppr instr) - +genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) + => BlockMap RegSet + -> [instr] + -> BlockId + -> instr + -> [Reg] + -> [Reg] + -> RegM freeRegs ([instr], [NatBasicBlock instr]) genRaInsn block_live new_instrs block_id instr r_dying w_dying = case regUsageOfInstr instr of { RU read written -> @@ -463,6 +510,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = -- ----------------------------------------------------------------------------- -- releaseRegs +releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () releaseRegs regs = do assig <- getAssigR free <- getFreeRegsR @@ -470,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 @@ -500,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 [instr] -- return: instructions to spill any temps that will + -> RegM freeRegs [instr] -- return: instructions to spill any temps that will -- be clobbered. saveClobberedTemps [] _ @@ -539,14 +587,14 @@ saveClobberedTemps clobbered dying -- | Mark all these real regs as allocated, -- and kick out their vreg assignments. -- -clobberRegs :: [RealReg] -> RegM () +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) @@ -589,14 +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 ( [instr] - , [RealReg]) + -> RegM freeRegs ( [instr] , [RealReg]) allocateRegsAndSpill _ _ spills alloc [] = return (spills, reverse alloc) @@ -634,10 +681,20 @@ 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 :: (FR freeRegs, Instruction instr, Outputable instr) + => Bool + -> [VirtualReg] + -> [instr] + -> [RealReg] + -> VirtualReg + -> [VirtualReg] + -> UniqFM Loc + -> SpillLoc + -> 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 @@ -646,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 @@ -715,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 @@ -734,7 +791,7 @@ loadTemp -> SpillLoc -- the current location of this temp -> RealReg -- the hreg to load the temp into -> [instr] - -> RegM [instr] + -> RegM freeRegs [instr] loadTemp vreg (ReadMem slot) hreg spills = do