X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FLinear%2FMain.hs;h=473b549a149845943464aef5d5d6775634b97a34;hb=6cec61d14a324285dbb8ce73d4c7215f1f8d6766;hp=229fd32f5722f53ff5c2dec7cbf20dd56845c86e;hpb=85981a6fc4bb94af433b0b3655c26c5ec4dda1bd;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 229fd32..473b549 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -48,7 +48,7 @@ The algorithm is roughly: (c) Update the current assignment - (d) If the intstruction is a branch: + (d) If the instruction is a branch: if the destination block already has a register assignment, Generate a new block with fixup code and redirect the jump to the new block. @@ -102,7 +102,7 @@ import Instruction import Reg import BlockId -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) import Digraph import Unique @@ -132,12 +132,12 @@ regAlloc (CmmData sec d) ( CmmData sec d , Nothing ) -regAlloc (CmmProc (LiveInfo info _ _) lbl params []) - = return ( CmmProc info lbl params (ListGraph []) +regAlloc (CmmProc (LiveInfo info _ _ _) lbl []) + = return ( CmmProc info lbl (ListGraph []) , Nothing ) -regAlloc (CmmProc static lbl params sccs) - | LiveInfo info (Just first_id) (Just block_live) <- static +regAlloc (CmmProc static lbl sccs) + | LiveInfo info (Just first_id) (Just block_live) _ <- static = do -- do register allocation on each component. (final_blocks, stats) @@ -148,11 +148,11 @@ regAlloc (CmmProc static lbl params sccs) let ((first':_), rest') = partition ((== first_id) . blockId) final_blocks - return ( CmmProc info lbl params (ListGraph (first' : rest')) + return ( CmmProc info lbl (ListGraph (first' : rest')) , Just stats) -- bogus. to make non-exhaustive match warning go away. -regAlloc (CmmProc _ _ _ _) +regAlloc (CmmProc _ _ _) = panic "RegAllocLinear.regAlloc: no match" @@ -190,7 +190,7 @@ linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) = do - blockss' <- process first_id block_live blocks [] (return []) + blockss' <- process first_id block_live blocks [] (return []) False linearRA_SCCs first_id block_live (reverse (concat blockss') ++ blocksAcc) sccs @@ -206,24 +206,37 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) some reason then this function will loop. We should probably do some more sanity checking to guard against this eventuality. -} - -process _ _ [] [] accum + +process _ _ [] [] accum _ = return $ reverse accum -process first_id block_live [] next_round accum - = process first_id block_live next_round [] accum +process first_id block_live [] next_round accum madeProgress + | not madeProgress + + {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. + pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out." + ( text "Unreachable blocks:" + $$ vcat (map ppr next_round)) -} + = return $ reverse accum + + | otherwise + = process first_id block_live + next_round [] accum False -process first_id block_live (b@(BasicBlock id _) : blocks) next_round accum +process first_id block_live (b@(BasicBlock id _) : blocks) + next_round accum madeProgress = do block_assig <- getBlockAssigR - if isJust (lookupBlockEnv block_assig id) + if isJust (mapLookup id block_assig) || id == first_id then do b' <- processBlock block_live b - process first_id block_live blocks next_round (b' : accum) + process first_id block_live blocks + next_round (b' : accum) True - else process first_id block_live blocks (b : next_round) accum + else process first_id block_live blocks + (b : next_round) accum madeProgress -- | Do register allocation on this basic block @@ -246,7 +259,7 @@ processBlock block_live (BasicBlock id instrs) initBlock :: BlockId -> RegM () initBlock id = do block_assig <- getBlockAssigR - case lookupBlockEnv block_assig id of + case mapLookup id block_assig of -- no prior info about this block: assume everything is -- free and the assignment is empty. Nothing @@ -282,7 +295,7 @@ linearRA _ accInstr accFixup _ [] linearRA block_live accInstr accFixups id (instr:instrs) = do - (accInstr', new_fixups) + (accInstr', new_fixups) <- raInsn block_live accInstr id instr linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs @@ -299,17 +312,17 @@ raInsn ( [instr] -- new instructions , [NatBasicBlock instr]) -- extra fixup blocks -raInsn _ new_instrs _ (Instr ii Nothing) +raInsn _ new_instrs _ (LiveInstr ii Nothing) | Just n <- takeDeltaInstr ii = do setDeltaR n return (new_instrs, []) -raInsn _ new_instrs _ (Instr ii Nothing) +raInsn _ new_instrs _ (LiveInstr ii Nothing) | isMetaInstr ii = return (new_instrs, []) -raInsn block_live new_instrs id (Instr instr (Just live)) +raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do assig <- getAssigR @@ -318,7 +331,7 @@ raInsn block_live new_instrs id (Instr instr (Just live)) -- register does not already have an assignment, -- and the source register is assigned to a register, not to a spill slot, -- then we can eliminate the instruction. - -- (we can't eliminitate it if the source register is on the stack, because + -- (we can't eliminate it if the source register is on the stack, because -- we do not want to use one spill slot for different virtual registers) case takeRegRegMoveInstr instr of Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), @@ -370,7 +383,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = clobber_saves <- saveClobberedTemps real_written r_dying -- debugging -{- freeregs <- getFreeRegsR +{- freeregs <- getFreeRegsR assig <- getAssigR pprTrace "genRaInsn" (ppr instr @@ -484,7 +497,7 @@ releaseRegs regs = do saveClobberedTemps - :: Instruction instr + :: (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 @@ -523,7 +536,7 @@ saveClobberedTemps clobbered dying --- | Mark all these regal regs as allocated, +-- | Mark all these real regs as allocated, -- and kick out their vreg assignments. -- clobberRegs :: [RealReg] -> RegM () @@ -558,6 +571,16 @@ clobberRegs clobbered -- ----------------------------------------------------------------------------- -- allocateRegsAndSpill +-- Why are we performing a spill? +data SpillLoc = ReadMem StackSlot -- reading from register only in memory + | WriteNew -- writing to a new variable + | WriteMem -- writing to register only in memory +-- Note that ReadNew is not valid, since you don't want to be reading +-- from an uninitialized register. We also don't need the location of +-- the register in memory, since that will be invalidated by the write. +-- Technically, we could coalesce WriteNew and WriteMem into a single +-- entry as well. -- EZY + -- This function does several things: -- For each temporary referred to by this instruction, -- we allocate a real register (spilling another temporary if necessary). @@ -566,7 +589,7 @@ clobberRegs clobbered -- the list of free registers and free stack slots. allocateRegsAndSpill - :: Instruction instr + :: (Outputable instr, Instruction instr) => Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out -> [instr] -- spill insns @@ -580,13 +603,14 @@ allocateRegsAndSpill _ _ spills alloc [] allocateRegsAndSpill reading keep spills alloc (r:rs) = do assig <- getAssigR + let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig case lookupUFM assig r of -- case (1a): already in a register Just (InReg my_reg) -> allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignemnt to be + -- NB1. if we're writing this register, update its assignment to be -- InReg, because the memory value is no longer valid. -- NB2. This is why we must process written registers here, even if they -- are also read by the same instruction. @@ -595,10 +619,22 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one... - loc -> allocRegsAndSpill_spill reading keep spills alloc r rs loc assig + Just (InMem slot) | reading -> doSpill (ReadMem slot) + | otherwise -> doSpill WriteMem + Nothing | reading -> + -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) + -- ToDo: This case should be a panic, but we + -- sometimes see an unreachable basic block which + -- triggers this because the register allocator + -- will start with an empty assignment. + doSpill WriteNew + + | otherwise -> doSpill WriteNew -allocRegsAndSpill_spill reading keep spills alloc r rs loc assig +-- 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 reading keep spills alloc r rs assig spill_loc = do freeRegs <- getFreeRegsR let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs @@ -607,19 +643,9 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig -- case (2): we have a free register (my_reg : _) -> - do spills' <- loadTemp reading r loc my_reg spills - - let new_loc - -- if the tmp was in a slot, then now its in a reg as well - | Just (InMem slot) <- loc - , reading - = InBoth my_reg slot - - -- tmp has been loaded into a reg - | otherwise - = InReg my_reg + do spills' <- loadTemp r spill_loc my_reg spills - setAssigR (addToUFM assig r $! new_loc) + setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) setFreeRegsR $ allocateReg my_reg freeRegs allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs @@ -649,9 +675,9 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig -- we have a temporary that is in both register and mem, -- just free up its register for use. | (temp, my_reg, slot) : _ <- candidates_inBoth - = do spills' <- loadTemp reading r loc my_reg spills + = do spills' <- loadTemp r spill_loc my_reg spills let assig1 = addToUFM assig temp (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg setAssigR assig2 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs @@ -671,11 +697,11 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig -- update the register assignment let assig1 = addToUFM assig temp_to_push_out (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg setAssigR assig2 -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp reading r loc my_reg spills + spills' <- loadTemp r spill_loc my_reg spills allocateRegsAndSpill reading keep (spill_store ++ spills') @@ -694,22 +720,28 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig result --- | Load up a spilled temporary if we need to. +-- | Calculate a new location after a register has been loaded. +newLocation :: SpillLoc -> RealReg -> Loc +-- if the tmp was read from a slot, then now its in a reg as well +newLocation (ReadMem slot) my_reg = InBoth my_reg slot +-- writes will always result in only the register being available +newLocation _ my_reg = InReg my_reg + +-- | Load up a spilled temporary if we need to (read from memory). loadTemp - :: Instruction instr - => Bool - -> VirtualReg -- the temp being loaded - -> Maybe Loc -- the current location of this temp + :: (Outputable instr, Instruction instr) + => VirtualReg -- the temp being loaded + -> SpillLoc -- the current location of this temp -> RealReg -- the hreg to load the temp into -> [instr] -> RegM [instr] -loadTemp True vreg (Just (InMem slot)) hreg spills +loadTemp vreg (ReadMem slot) hreg spills = do insn <- loadR (RegReal hreg) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- COMMENT (fsLit "spill load") : -} insn : spills -loadTemp _ _ _ _ spills = +loadTemp _ _ _ spills = return spills