diff options
Diffstat (limited to 'compiler/nativeGen/RegAlloc/Linear')
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/Base.hs | 10 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs | 28 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs | 458 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/Main.hs | 214 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/StackMap.hs | 6 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/State.hs | 139 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs | 27 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs | 52 |
8 files changed, 492 insertions, 442 deletions
diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs index 432acdf314..e58331347c 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Base.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs @@ -13,7 +13,6 @@ module RegAlloc.Linear.Base ( -- the allocator monad RA_State(..), - RegM(..) ) where @@ -22,6 +21,7 @@ import RegAlloc.Linear.StackMap import RegAlloc.Liveness import Reg +import DynFlags import Outputable import Unique import UniqFM @@ -126,11 +126,7 @@ data RA_State freeRegs -- | Record why things were spilled, for -ddrop-asm-stats. -- Just keep a list here instead of a map of regs -> reasons. -- We don't want to slow down the allocator if we're not going to emit the stats. - , ra_spills :: [SpillReason] } - - --- | The register allocator monad type. -newtype RegM freeRegs a - = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) } + , ra_spills :: [SpillReason] + , ra_DynFlags :: DynFlags } diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index 887af1758a..fffdef761b 100644 --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -18,6 +18,7 @@ where import Reg import RegClass +import DynFlags import Panic import Platform @@ -33,9 +34,10 @@ import Platform -- 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 RegAlloc.Linear.PPC.FreeRegs as PPC +import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC +import qualified RegAlloc.Linear.X86.FreeRegs as X86 +import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64 import qualified PPC.Instr import qualified SPARC.Instr @@ -53,6 +55,12 @@ instance FR X86.FreeRegs where frInitFreeRegs = X86.initFreeRegs frReleaseReg = \_ -> X86.releaseReg +instance FR X86_64.FreeRegs where + frAllocateReg = \_ -> X86_64.allocateReg + frGetFreeRegs = X86_64.getFreeRegs + frInitFreeRegs = X86_64.initFreeRegs + frReleaseReg = \_ -> X86_64.releaseReg + instance FR PPC.FreeRegs where frAllocateReg = \_ -> PPC.allocateReg frGetFreeRegs = \_ -> PPC.getFreeRegs @@ -65,13 +73,13 @@ instance FR SPARC.FreeRegs where frInitFreeRegs = SPARC.initFreeRegs frReleaseReg = SPARC.releaseReg -maxSpillSlots :: Platform -> Int -maxSpillSlots platform - = case platformArch platform of - ArchX86 -> X86.Instr.maxSpillSlots True -- 32bit - ArchX86_64 -> X86.Instr.maxSpillSlots False -- not 32bit - ArchPPC -> PPC.Instr.maxSpillSlots - ArchSPARC -> SPARC.Instr.maxSpillSlots +maxSpillSlots :: DynFlags -> Int +maxSpillSlots dflags + = case platformArch (targetPlatform dflags) of + ArchX86 -> X86.Instr.maxSpillSlots dflags + ArchX86_64 -> X86.Instr.maxSpillSlots dflags + ArchPPC -> PPC.Instr.maxSpillSlots dflags + ArchSPARC -> SPARC.Instr.maxSpillSlots dflags ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" 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 ea415e2661..6294743c48 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -1,24 +1,13 @@ -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Handles joining of a jump instruction to its targets. --- The first time we encounter a jump to a particular basic block, we --- record the assignment of temporaries. The next time we encounter a --- jump to the same block, we compare our current assignment to the --- stored one. They might be different if spilling has occrred in one --- branch; so some fixup code will be required to match up the assignments. +-- The first time we encounter a jump to a particular basic block, we +-- record the assignment of temporaries. The next time we encounter a +-- jump to the same block, we compare our current assignment to the +-- stored one. They might be different if spilling has occrred in one +-- branch; so some fixup code will be required to match up the assignments. -- -module RegAlloc.Linear.JoinToTargets ( - joinToTargets -) - -where +module RegAlloc.Linear.JoinToTargets (joinToTargets) where import RegAlloc.Linear.State import RegAlloc.Linear.Base @@ -30,96 +19,94 @@ import Reg import BlockId import OldCmm hiding (RegSet) import Digraph +import DynFlags import Outputable -import Platform import Unique import UniqFM import UniqSet -- | For a jump instruction at the end of a block, generate fixup code so its --- vregs are in the correct regs for its destination. +-- vregs are in the correct regs for its destination. -- joinToTargets - :: (FR freeRegs, Instruction instr) - => Platform - -> 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. + :: (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. + -> 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. - , instr) -- the original branch instruction, but maybe patched to jump - -- to a fixup block first. + -> 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 platform block_live id instr +joinToTargets block_live id instr - -- we only need to worry about jump instructions. - | not $ isJumpishInstr instr - = return ([], instr) + -- we only need to worry about jump instructions. + | not $ isJumpishInstr instr + = return ([], instr) - | otherwise - = joinToTargets' platform block_live [] id instr (jumpDestsOfInstr instr) + | otherwise + = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr) ----- joinToTargets' - :: (FR freeRegs, Instruction instr) - => Platform - -> 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. + :: (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. - -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. + -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. - -> BlockId -- ^ id of the current block - -> instr -- ^ branch instr on the end of the source block. + -> BlockId -- ^ id of the current block + -> instr -- ^ branch instr on the end of the source block. - -> [BlockId] -- ^ branch destinations still to consider. + -> [BlockId] -- ^ branch destinations still to consider. - -> RegM freeRegs ( [NatBasicBlock instr] - , instr) + -> RegM freeRegs ([NatBasicBlock instr], instr) -- no more targets to consider. all done. -joinToTargets' _ _ new_blocks _ instr [] - = return (new_blocks, instr) +joinToTargets' _ new_blocks _ instr [] + = return (new_blocks, instr) -- handle a branch target. -joinToTargets' platform block_live new_blocks block_id instr (dest:dests) - = do - -- get the map of where the vregs are stored on entry to each basic block. - block_assig <- getBlockAssigR - - -- get the assignment on entry to the branch instruction. - assig <- getAssigR - - -- adjust the current assignment to remove any vregs that are not live - -- on entry to the destination block. - let Just live_set = mapLookup dest block_live - let still_live uniq _ = uniq `elemUniqSet_Directly` live_set - let adjusted_assig = filterUFM_Directly still_live assig - - -- and free up those registers which are now free. - let to_free = - [ r | (reg, loc) <- ufmToList assig - , not (elemUniqSet_Directly reg live_set) - , r <- regsOfLoc loc ] - - case mapLookup dest block_assig of - Nothing - -> joinToTargets_first - platform block_live new_blocks block_id instr dest dests - block_assig adjusted_assig to_free - - Just (_, dest_assig) - -> joinToTargets_again - platform block_live new_blocks block_id instr dest dests - adjusted_assig dest_assig +joinToTargets' block_live new_blocks block_id instr (dest:dests) + = do + -- get the map of where the vregs are stored on entry to each basic block. + block_assig <- getBlockAssigR + + -- get the assignment on entry to the branch instruction. + assig <- getAssigR + + -- adjust the current assignment to remove any vregs that are not live + -- on entry to the destination block. + let Just live_set = mapLookup dest block_live + let still_live uniq _ = uniq `elemUniqSet_Directly` live_set + let adjusted_assig = filterUFM_Directly still_live assig + + -- and free up those registers which are now free. + let to_free = + [ r | (reg, loc) <- ufmToList assig + , not (elemUniqSet_Directly reg live_set) + , r <- regsOfLoc loc ] + + case mapLookup dest block_assig of + Nothing + -> joinToTargets_first + block_live new_blocks block_id instr dest dests + block_assig adjusted_assig to_free + + Just (_, dest_assig) + -> joinToTargets_again + block_live new_blocks block_id instr dest dests + adjusted_assig dest_assig -- this is the first time we jumped to this block. joinToTargets_first :: (FR freeRegs, Instruction instr) - => Platform - -> BlockMap RegSet + => BlockMap RegSet -> [NatBasicBlock instr] -> BlockId -> instr @@ -129,24 +116,26 @@ joinToTargets_first :: (FR freeRegs, Instruction instr) -> RegMap Loc -> [RealReg] -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_first platform block_live new_blocks block_id instr dest dests - block_assig src_assig - to_free +joinToTargets_first block_live new_blocks block_id instr dest dests + block_assig src_assig + to_free - = do -- free up the regs that are not live on entry to this block. - freeregs <- getFreeRegsR - let freeregs' = foldr (frReleaseReg platform) freeregs to_free - - -- remember the current assignment on entry to this block. - setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) + = do dflags <- getDynFlags + let platform = targetPlatform dflags - joinToTargets' platform block_live new_blocks block_id instr dests + -- free up the regs that are not live on entry to this block. + freeregs <- getFreeRegsR + let freeregs' = foldr (frReleaseReg platform) freeregs to_free + + -- remember the current assignment on entry to this block. + setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) + + joinToTargets' block_live new_blocks block_id instr dests -- we've jumped to this block before joinToTargets_again :: (Instruction instr, FR freeRegs) - => Platform - -> BlockMap RegSet + => BlockMap RegSet -> [NatBasicBlock instr] -> BlockId -> instr @@ -156,82 +145,82 @@ joinToTargets_again :: (Instruction instr, FR freeRegs) -> UniqFM Loc -> RegM freeRegs ([NatBasicBlock instr], instr) joinToTargets_again - platform block_live new_blocks block_id instr dest dests + block_live new_blocks block_id instr dest dests src_assig dest_assig - -- the assignments already match, no problem. - | ufmToList dest_assig == ufmToList src_assig - = joinToTargets' platform block_live new_blocks block_id instr dests - - -- assignments don't match, need fixup code - | otherwise - = do - - -- make a graph of what things need to be moved where. - let graph = makeRegMovementGraph src_assig dest_assig - - -- look for cycles in the graph. This can happen if regs need to be swapped. - -- Note that we depend on the fact that this function does a - -- bottom up traversal of the tree-like portions of the graph. - -- - -- eg, if we have - -- R1 -> R2 -> R3 - -- - -- ie move value in R1 to R2 and value in R2 to R3. - -- - -- We need to do the R2 -> R3 move before R1 -> R2. - -- - let sccs = stronglyConnCompFromEdgedVerticesR graph - -{- -- debugging - pprTrace - ("joinToTargets: making fixup code") - (vcat [ text " in block: " <> ppr block_id - , text " jmp instruction: " <> ppr instr - , text " src assignment: " <> ppr src_assig - , text " dest assignment: " <> ppr dest_assig - , text " movement graph: " <> ppr graph - , text " sccs of graph: " <> ppr sccs - , text ""]) - (return ()) + -- the assignments already match, no problem. + | ufmToList dest_assig == ufmToList src_assig + = joinToTargets' block_live new_blocks block_id instr dests + + -- assignments don't match, need fixup code + | otherwise + = do + + -- make a graph of what things need to be moved where. + let graph = makeRegMovementGraph src_assig dest_assig + + -- look for cycles in the graph. This can happen if regs need to be swapped. + -- Note that we depend on the fact that this function does a + -- bottom up traversal of the tree-like portions of the graph. + -- + -- eg, if we have + -- R1 -> R2 -> R3 + -- + -- ie move value in R1 to R2 and value in R2 to R3. + -- + -- We need to do the R2 -> R3 move before R1 -> R2. + -- + let sccs = stronglyConnCompFromEdgedVerticesR graph + +{- -- debugging + pprTrace + ("joinToTargets: making fixup code") + (vcat [ text " in block: " <> ppr block_id + , text " jmp instruction: " <> ppr instr + , text " src assignment: " <> ppr src_assig + , text " dest assignment: " <> ppr dest_assig + , text " movement graph: " <> ppr graph + , text " sccs of graph: " <> ppr sccs + , text ""]) + (return ()) -} - delta <- getDeltaR - fixUpInstrs_ <- mapM (handleComponent platform delta instr) sccs - let fixUpInstrs = concat fixUpInstrs_ - - -- make a new basic block containing the fixup code. - -- A the end of the current block we will jump to the fixup one, - -- then that will jump to our original destination. - fixup_block_id <- getUniqueR - let block = BasicBlock (mkBlockId fixup_block_id) - $ fixUpInstrs ++ mkJumpInstr dest - -{- pprTrace - ("joinToTargets: fixup code is:") - (vcat [ ppr block - , text ""]) - (return ()) + delta <- getDeltaR + fixUpInstrs_ <- mapM (handleComponent delta instr) sccs + let fixUpInstrs = concat fixUpInstrs_ + + -- make a new basic block containing the fixup code. + -- A the end of the current block we will jump to the fixup one, + -- then that will jump to our original destination. + fixup_block_id <- getUniqueR + let block = BasicBlock (mkBlockId fixup_block_id) + $ fixUpInstrs ++ mkJumpInstr dest + +{- pprTrace + ("joinToTargets: fixup code is:") + (vcat [ ppr block + , text ""]) + (return ()) -} - -- if we didn't need any fixups, then don't include the block - case fixUpInstrs of - [] -> joinToTargets' platform block_live new_blocks block_id instr dests + -- if we didn't need any fixups, then don't include the block + case fixUpInstrs of + [] -> joinToTargets' block_live new_blocks block_id instr dests - -- patch the original branch instruction so it goes to our - -- fixup block instead. - _ -> let instr' = patchJumpInstr instr - (\bid -> if bid == dest - then mkBlockId fixup_block_id - else bid) -- no change! - - in joinToTargets' platform block_live (block : new_blocks) block_id instr' dests + -- patch the original branch instruction so it goes to our + -- fixup block instead. + _ -> let instr' = patchJumpInstr instr + (\bid -> if bid == dest + then mkBlockId fixup_block_id + else bid) -- no change! + + in joinToTargets' block_live (block : new_blocks) block_id instr' dests -- | Construct a graph of register\/spill movements. -- --- Cyclic components seem to occur only very rarely. +-- Cyclic components seem to occur only very rarely. -- --- We cut some corners by not handling memory-to-memory moves. --- This shouldn't happen because every temporary gets its own stack slot. +-- We cut some corners by not handling memory-to-memory moves. +-- This shouldn't happen because every temporary gets its own stack slot. -- makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])] makeRegMovementGraph adjusted_assig dest_assig @@ -242,95 +231,96 @@ makeRegMovementGraph adjusted_assig dest_assig -- | Expand out the destination, so InBoth destinations turn into --- a combination of InReg and InMem. +-- a combination of InReg and InMem. --- The InBoth handling is a little tricky here. If the destination is --- InBoth, then we must ensure that the value ends up in both locations. --- An InBoth destination must conflict with an InReg or InMem source, so --- we expand an InBoth destination as necessary. +-- The InBoth handling is a little tricky here. If the destination is +-- InBoth, then we must ensure that the value ends up in both locations. +-- An InBoth destination must conflict with an InReg or InMem source, so +-- we expand an InBoth destination as necessary. -- --- An InBoth source is slightly different: we only care about the register --- that the source value is in, so that we can move it to the destinations. +-- An InBoth source is slightly different: we only care about the register +-- that the source value is in, so that we can move it to the destinations. -- -expandNode - :: a - -> Loc -- ^ source of move - -> Loc -- ^ destination of move - -> [(a, Loc, [Loc])] +expandNode + :: a + -> Loc -- ^ source of move + -> Loc -- ^ destination of move + -> [(a, Loc, [Loc])] expandNode vreg loc@(InReg src) (InBoth dst mem) - | src == dst = [(vreg, loc, [InMem mem])] - | otherwise = [(vreg, loc, [InReg dst, InMem mem])] + | src == dst = [(vreg, loc, [InMem mem])] + | otherwise = [(vreg, loc, [InReg dst, InMem mem])] expandNode vreg loc@(InMem src) (InBoth dst mem) - | src == mem = [(vreg, loc, [InReg dst])] - | otherwise = [(vreg, loc, [InReg dst, InMem mem])] + | src == mem = [(vreg, loc, [InReg dst])] + | otherwise = [(vreg, loc, [InReg dst, InMem mem])] expandNode _ (InBoth _ src) (InMem dst) - | src == dst = [] -- guaranteed to be true + | src == dst = [] -- guaranteed to be true expandNode _ (InBoth src _) (InReg dst) - | src == dst = [] + | src == dst = [] expandNode vreg (InBoth src _) dst - = expandNode vreg (InReg src) dst + = expandNode vreg (InReg src) dst expandNode vreg src dst - | src == dst = [] - | otherwise = [(vreg, src, [dst])] + | src == dst = [] + | otherwise = [(vreg, src, [dst])] -- | Generate fixup code for a particular component in the move graph --- This component tells us what values need to be moved to what --- destinations. We have eliminated any possibility of single-node --- cycles in expandNode above. +-- This component tells us what values need to be moved to what +-- destinations. We have eliminated any possibility of single-node +-- cycles in expandNode above. -- -handleComponent - :: Instruction instr - => Platform -> Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [instr] +handleComponent + :: Instruction 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 --- go via a spill slot. +-- In this case we can just do the moves directly, and avoid having to +-- go via a spill slot. -- -handleComponent platform delta _ (AcyclicSCC (vreg, src, dsts)) - = mapM (makeMove platform delta vreg src) dsts +handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) + = mapM (makeMove delta vreg src) dsts -- Handle some cyclic moves. --- This can happen if we have two regs that need to be swapped. --- eg: --- vreg source loc dest loc --- (vreg1, InReg r1, [InReg r2]) --- (vreg2, InReg r2, [InReg r1]) +-- This can happen if we have two regs that need to be swapped. +-- eg: +-- vreg source loc dest loc +-- (vreg1, InReg r1, [InReg r2]) +-- (vreg2, InReg r2, [InReg r1]) +-- +-- To avoid needing temp register, we just spill all the source regs, then +-- reaload them into their destination regs. -- --- To avoid needing temp register, we just spill all the source regs, then --- reaload them into their destination regs. --- --- Note that we can not have cycles that involve memory locations as --- sources as single destination because memory locations (stack slots) --- are allocated exclusively for a virtual register and therefore can not --- require a fixup. +-- Note that we can not have cycles that involve memory locations as +-- sources as single destination because memory locations (stack slots) +-- are allocated exclusively for a virtual register and therefore can not +-- require a fixup. -- -handleComponent platform delta instr - (CyclicSCC ( (vreg, InReg sreg, (InReg dreg: _)) : rest)) +handleComponent delta instr + (CyclicSCC ((vreg, InReg sreg, (InReg dreg: _)) : rest)) -- dest list may have more than one element, if the reg is also InMem. = do - -- spill the source into its slot - (instrSpill, slot) - <- spillR platform (RegReal sreg) vreg + -- spill the source into its slot + (instrSpill, slot) + <- spillR (RegReal sreg) vreg - -- reload into destination reg - instrLoad <- loadR platform (RegReal dreg) slot - - remainingFixUps <- mapM (handleComponent platform delta instr) - (stronglyConnCompFromEdgedVerticesR rest) + -- reload into destination reg + instrLoad <- loadR (RegReal dreg) slot - -- make sure to do all the reloads after all the spills, - -- so we don't end up clobbering the source values. - return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) + remainingFixUps <- mapM (handleComponent delta instr) + (stronglyConnCompFromEdgedVerticesR rest) -handleComponent _ _ _ (CyclicSCC _) + -- make sure to do all the reloads after all the spills, + -- so we don't end up clobbering the source values. + return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) + +handleComponent _ _ (CyclicSCC _) = panic "Register Allocator: handleComponent cyclic" @@ -338,29 +328,31 @@ handleComponent _ _ _ (CyclicSCC _) -- makeMove :: Instruction instr - => Platform - -> Int -- ^ current C stack delta. + => Int -- ^ current C stack delta. -> Unique -- ^ unique of the vreg that we're moving. -> Loc -- ^ source location. -> Loc -- ^ destination location. -> RegM freeRegs instr -- ^ move instruction. -makeMove platform _ vreg (InReg src) (InReg dst) - = do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr platform (RegReal src) (RegReal dst) - -makeMove platform delta vreg (InMem src) (InReg dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr platform (RegReal dst) delta src - -makeMove platform delta vreg (InReg src) (InMem dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr platform (RegReal src) delta dst - --- we don't handle memory to memory moves. --- they shouldn't happen because we don't share stack slots between vregs. -makeMove _ _ vreg src dst - = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" - ++ show dst ++ ")" - ++ " we don't handle mem->mem moves." +makeMove delta vreg src dst + = do dflags <- getDynFlags + let platform = targetPlatform dflags + + case (src, dst) of + (InReg s, InReg d) -> + do recordSpill (SpillJoinRR vreg) + return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d) + (InMem s, InReg d) -> + do recordSpill (SpillJoinRM vreg) + return $ mkLoadInstr dflags (RegReal d) delta s + (InReg s, InMem d) -> + do recordSpill (SpillJoinRM vreg) + return $ mkSpillInstr dflags (RegReal s) delta d + _ -> + -- we don't handle memory to memory moves. + -- they shouldn't happen because we don't share + -- stack slots between vregs. + panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" + ++ show dst ++ ")" + ++ " we don't handle mem->mem moves.") diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index c2f89de641..3f92ed975b 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -106,9 +106,10 @@ 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 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 RegAlloc.Linear.X86_64.FreeRegs as X86_64 import TargetReg import RegAlloc.Liveness import Instruction @@ -188,52 +189,51 @@ linearRegAlloc linearRegAlloc dflags first_id block_live sccs = let platform = targetPlatform dflags in case platformArch platform of - ArchX86 -> linearRegAlloc' platform (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs - ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs - ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs platform :: SPARC.FreeRegs) first_id block_live sccs - ArchPPC -> linearRegAlloc' platform (frInitFreeRegs platform :: PPC.FreeRegs) first_id block_live sccs + ArchX86 -> linearRegAlloc' dflags (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs + ArchX86_64 -> linearRegAlloc' dflags (frInitFreeRegs platform :: X86_64.FreeRegs) first_id block_live sccs + ArchSPARC -> linearRegAlloc' dflags (frInitFreeRegs platform :: SPARC.FreeRegs) first_id block_live sccs + ArchPPC -> linearRegAlloc' dflags (frInitFreeRegs platform :: PPC.FreeRegs) first_id block_live sccs ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" ArchUnknown -> panic "linearRegAlloc ArchUnknown" linearRegAlloc' :: (FR freeRegs, Outputable instr, Instruction instr) - => Platform + => DynFlags -> 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' platform initFreeRegs first_id block_live sccs +linearRegAlloc' dflags initFreeRegs first_id block_live sccs = do us <- getUs let (_, _, stats, blocks) = - runR emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap platform) us - $ linearRA_SCCs platform first_id block_live [] sccs + runR dflags emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap dflags) us + $ linearRA_SCCs first_id block_live [] sccs return (blocks, stats) linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) - => Platform - -> BlockId + => BlockId -> BlockMap RegSet -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] -> RegM freeRegs [NatBasicBlock instr] -linearRA_SCCs _ _ _ blocksAcc [] +linearRA_SCCs _ _ blocksAcc [] = return $ reverse blocksAcc -linearRA_SCCs platform first_id block_live blocksAcc (AcyclicSCC block : sccs) - = do blocks' <- processBlock platform block_live block - linearRA_SCCs platform first_id block_live +linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) + = do blocks' <- processBlock block_live block + linearRA_SCCs first_id block_live ((reverse blocks') ++ blocksAcc) sccs -linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs) +linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) = do - blockss' <- process platform first_id block_live blocks [] (return []) False - linearRA_SCCs platform first_id block_live + blockss' <- process first_id block_live blocks [] (return []) False + linearRA_SCCs first_id block_live (reverse (concat blockss') ++ blocksAcc) sccs @@ -250,8 +250,7 @@ linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs) -} process :: (FR freeRegs, Instruction instr, Outputable instr) - => Platform - -> BlockId + => BlockId -> BlockMap RegSet -> [GenBasicBlock (LiveInstr instr)] -> [GenBasicBlock (LiveInstr instr)] @@ -259,10 +258,10 @@ process :: (FR freeRegs, Instruction instr, Outputable instr) -> Bool -> RegM freeRegs [[NatBasicBlock instr]] -process _ _ _ [] [] accum _ +process _ _ [] [] accum _ = return $ reverse accum -process platform first_id block_live [] next_round accum madeProgress +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. @@ -272,10 +271,10 @@ process platform first_id block_live [] next_round accum madeProgress = return $ reverse accum | otherwise - = process platform first_id block_live + = process first_id block_live next_round [] accum False -process platform first_id block_live (b@(BasicBlock id _) : blocks) +process first_id block_live (b@(BasicBlock id _) : blocks) next_round accum madeProgress = do block_assig <- getBlockAssigR @@ -283,11 +282,11 @@ process platform first_id block_live (b@(BasicBlock id _) : blocks) if isJust (mapLookup id block_assig) || id == first_id then do - b' <- processBlock platform block_live b - process platform first_id block_live blocks + b' <- processBlock block_live b + process first_id block_live blocks next_round (b' : accum) True - else process platform first_id block_live blocks + else process first_id block_live blocks (b : next_round) accum madeProgress @@ -295,24 +294,25 @@ process platform first_id block_live (b@(BasicBlock id _) : blocks) -- processBlock :: (FR freeRegs, Outputable instr, Instruction instr) - => Platform - -> BlockMap RegSet -- ^ live regs on entry to each basic block + => 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 -processBlock platform block_live (BasicBlock id instrs) - = do initBlock platform id block_live +processBlock block_live (BasicBlock id instrs) + = do initBlock id block_live (instrs', fixups) - <- linearRA platform block_live [] [] id instrs + <- linearRA block_live [] [] id instrs return $ BasicBlock id instrs' : fixups -- | Load the freeregs and current reg assignment into the RegM state -- for the basic block with this BlockId. initBlock :: FR freeRegs - => Platform -> BlockId -> BlockMap RegSet -> RegM freeRegs () -initBlock platform id block_live - = do block_assig <- getBlockAssigR + => BlockId -> BlockMap RegSet -> RegM freeRegs () +initBlock id block_live + = do dflags <- getDynFlags + let platform = targetPlatform dflags + block_assig <- getBlockAssigR case mapLookup id block_assig of -- no prior info about this block: we must consider -- any fixed regs to be allocated, but we can ignore @@ -337,8 +337,7 @@ initBlock platform id block_live -- | Do allocation for a sequence of instructions. linearRA :: (FR freeRegs, Outputable instr, Instruction instr) - => Platform - -> BlockMap RegSet -- ^ map of what vregs are live on entry to each block. + => 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. @@ -349,25 +348,23 @@ linearRA , [NatBasicBlock instr]) -- fresh blocks of fixup code. -linearRA _ _ accInstr accFixup _ [] +linearRA _ accInstr accFixup _ [] = return ( reverse accInstr -- instrs need to be returned in the correct order. , accFixup) -- it doesn't matter what order the fixup blocks are returned in. -linearRA platform block_live accInstr accFixups id (instr:instrs) +linearRA block_live accInstr accFixups id (instr:instrs) = do - (accInstr', new_fixups) - <- raInsn platform block_live accInstr id instr + (accInstr', new_fixups) <- raInsn block_live accInstr id instr - linearRA platform block_live accInstr' (new_fixups ++ accFixups) id instrs + linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs -- | Do allocation for a single instruction. raInsn :: (FR freeRegs, Outputable instr, Instruction instr) - => Platform - -> BlockMap RegSet -- ^ map of what vregs are love on entry to each block. + => 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. @@ -375,17 +372,17 @@ raInsn ( [instr] -- new instructions , [NatBasicBlock instr]) -- extra fixup blocks -raInsn _ _ new_instrs _ (LiveInstr ii Nothing) +raInsn _ new_instrs _ (LiveInstr ii Nothing) | Just n <- takeDeltaInstr ii = do setDeltaR n return (new_instrs, []) -raInsn _ _ new_instrs _ (LiveInstr ii Nothing) +raInsn _ new_instrs _ (LiveInstr ii Nothing) | isMetaInstr ii = return (new_instrs, []) -raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live)) +raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do assig <- getAssigR @@ -420,12 +417,12 @@ raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live)) -} return (new_instrs, []) - _ -> genRaInsn platform block_live new_instrs id instr + _ -> genRaInsn block_live new_instrs id instr (uniqSetToList $ liveDieRead live) (uniqSetToList $ liveDieWrite live) -raInsn _ _ _ _ instr +raInsn _ _ _ instr = pprPanic "raInsn" (text "no match for:" <> ppr instr) @@ -435,8 +432,7 @@ isInReg src assig | Just (InReg _) <- lookupUFM assig src = True genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) - => Platform - -> BlockMap RegSet + => BlockMap RegSet -> [instr] -> BlockId -> instr @@ -444,8 +440,10 @@ genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) -> [Reg] -> RegM freeRegs ([instr], [NatBasicBlock instr]) -genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = - case regUsageOfInstr platform instr of { RU read written -> +genRaInsn block_live new_instrs block_id instr r_dying w_dying = do + dflags <- getDynFlags + let platform = targetPlatform dflags + case regUsageOfInstr platform instr of { RU read written -> do let real_written = [ rr | (RegReal rr) <- written ] let virt_written = [ vr | (RegVirtual vr) <- written ] @@ -471,32 +469,32 @@ genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = -- (a), (b) allocate real regs for all regs read by this instruction. (r_spills, r_allocd) <- - allocateRegsAndSpill platform True{-reading-} virt_read [] [] virt_read + allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read -- (c) save any temporaries which will be clobbered by this instruction - clobber_saves <- saveClobberedTemps platform real_written r_dying + clobber_saves <- saveClobberedTemps real_written r_dying -- (d) Update block map for new destinations -- NB. do this before removing dead regs from the assignment, because -- these dead regs might in fact be live in the jump targets (they're -- only dead in the code that follows in the current basic block). (fixup_blocks, adjusted_instr) - <- joinToTargets platform block_live block_id instr + <- joinToTargets block_live block_id instr -- (e) Delete all register assignments for temps which are read -- (only) and die here. Update the free register list. - releaseRegs platform r_dying + releaseRegs r_dying -- (f) Mark regs which are clobbered as unallocatable - clobberRegs platform real_written + clobberRegs real_written -- (g) Allocate registers for temporaries *written* (only) (w_spills, w_allocd) <- - allocateRegsAndSpill platform False{-writing-} virt_written [] [] virt_written + allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written -- (h) Release registers for temps which are written here and not -- used again. - releaseRegs platform w_dying + releaseRegs w_dying let -- (i) Patch the instruction @@ -539,20 +537,23 @@ genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = -- ----------------------------------------------------------------------------- -- releaseRegs -releaseRegs :: FR freeRegs => Platform -> [Reg] -> RegM freeRegs () -releaseRegs platform regs = do +releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () +releaseRegs regs = do + dflags <- getDynFlags + let platform = targetPlatform dflags assig <- getAssigR free <- getFreeRegsR + let loop _ free _ | free `seq` False = undefined + loop assig free [] = do setAssigR assig; setFreeRegsR free; return () + loop assig free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs + loop assig free (r:rs) = + case lookupUFM assig r of + Just (InBoth real _) -> loop (delFromUFM assig r) + (frReleaseReg platform real free) rs + Just (InReg real) -> loop (delFromUFM assig r) + (frReleaseReg platform real free) rs + _ -> loop (delFromUFM assig r) free rs loop assig free regs - where - loop _ free _ | free `seq` False = undefined - loop assig free [] = do setAssigR assig; setFreeRegsR free; return () - loop assig free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs - loop assig free (r:rs) = - case lookupUFM assig r of - Just (InBoth real _) -> loop (delFromUFM assig r) (frReleaseReg platform real free) rs - Just (InReg real) -> loop (delFromUFM assig r) (frReleaseReg platform real free) rs - _other -> loop (delFromUFM assig r) free rs -- ----------------------------------------------------------------------------- @@ -571,16 +572,15 @@ releaseRegs platform regs = do saveClobberedTemps :: (Outputable instr, Instruction instr, FR freeRegs) - => Platform - -> [RealReg] -- real registers clobbered by this instruction + => [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 -- be clobbered. -saveClobberedTemps _ [] _ +saveClobberedTemps [] _ = return [] -saveClobberedTemps platform clobbered dying +saveClobberedTemps clobbered dying = do assig <- getAssigR let to_spill @@ -598,7 +598,9 @@ saveClobberedTemps platform clobbered dying = return (instrs, assig) clobber assig instrs ((temp, reg) : rest) - = do + = do dflags <- getDynFlags + let platform = targetPlatform dflags + freeRegs <- getFreeRegsR let regclass = targetClassOfRealReg platform reg freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs @@ -619,7 +621,7 @@ saveClobberedTemps platform clobbered dying -- (2) no free registers: spill the value [] -> do - (spill, slot) <- spillR platform (RegReal reg) temp + (spill, slot) <- spillR (RegReal reg) temp -- record why this reg was spilled for profiling recordSpill (SpillClobber temp) @@ -633,12 +635,14 @@ saveClobberedTemps platform clobbered dying -- | Mark all these real regs as allocated, -- and kick out their vreg assignments. -- -clobberRegs :: FR freeRegs => Platform -> [RealReg] -> RegM freeRegs () -clobberRegs _ [] +clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs () +clobberRegs [] = return () -clobberRegs platform clobbered - = do +clobberRegs clobbered + = do dflags <- getDynFlags + let platform = targetPlatform dflags + freeregs <- getFreeRegsR setFreeRegsR $! foldr (frAllocateReg platform) freeregs clobbered @@ -684,24 +688,23 @@ data SpillLoc = ReadMem StackSlot -- reading from register only in memory allocateRegsAndSpill :: (FR freeRegs, Outputable instr, Instruction instr) - => Platform - -> Bool -- True <=> reading (load up spilled regs) + => 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]) -allocateRegsAndSpill _ _ _ spills alloc [] +allocateRegsAndSpill _ _ spills alloc [] = return (spills, reverse alloc) -allocateRegsAndSpill platform reading keep spills alloc (r:rs) +allocateRegsAndSpill reading keep spills alloc (r:rs) = do assig <- getAssigR - let doSpill = allocRegsAndSpill_spill platform reading keep spills alloc r rs assig + 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 platform reading keep spills (my_reg:alloc) rs + 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 assignment to be @@ -710,7 +713,7 @@ allocateRegsAndSpill platform reading keep spills alloc (r:rs) -- are also read by the same instruction. Just (InBoth my_reg _) -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) - allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one... Just (InMem slot) | reading -> doSpill (ReadMem slot) @@ -729,8 +732,7 @@ allocateRegsAndSpill platform 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) - => Platform - -> Bool + => Bool -> [VirtualReg] -> [instr] -> [RealReg] @@ -739,8 +741,9 @@ allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) -> UniqFM Loc -> SpillLoc -> RegM freeRegs ([instr], [RealReg]) -allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc - = do +allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc + = do dflags <- getDynFlags + let platform = targetPlatform dflags freeRegs <- getFreeRegsR let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs @@ -748,12 +751,12 @@ allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc -- case (2): we have a free register (my_reg : _) -> - do spills' <- loadTemp platform r spill_loc my_reg spills + do spills' <- loadTemp r spill_loc my_reg spills setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) setFreeRegsR $ frAllocateReg platform my_reg freeRegs - allocateRegsAndSpill platform reading keep spills' (my_reg : alloc) rs + allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs -- case (3): we need to push something out to free up a register @@ -780,19 +783,19 @@ allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc -- 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 platform r spill_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 $! newLocation spill_loc my_reg setAssigR assig2 - allocateRegsAndSpill platform reading keep spills' (my_reg:alloc) rs + allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs -- otherwise, we need to spill a temporary that currently -- resides in a register. | (temp_to_push_out, (my_reg :: RealReg)) : _ <- candidates_inReg = do - (spill_insn, slot) <- spillR platform (RegReal my_reg) temp_to_push_out + (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out let spill_store = (if reading then id else reverse) [ -- COMMENT (fsLit "spill alloc") spill_insn ] @@ -806,9 +809,9 @@ allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc setAssigR assig2 -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp platform r spill_loc my_reg spills + spills' <- loadTemp r spill_loc my_reg spills - allocateRegsAndSpill platform reading keep + allocateRegsAndSpill reading keep (spill_store ++ spills') (my_reg:alloc) rs @@ -835,19 +838,18 @@ newLocation _ my_reg = InReg my_reg -- | Load up a spilled temporary if we need to (read from memory). loadTemp :: (Outputable instr, Instruction instr) - => Platform - -> VirtualReg -- the temp being loaded + => VirtualReg -- the temp being loaded -> SpillLoc -- the current location of this temp -> RealReg -- the hreg to load the temp into -> [instr] -> RegM freeRegs [instr] -loadTemp platform vreg (ReadMem slot) hreg spills +loadTemp vreg (ReadMem slot) hreg spills = do - insn <- loadR platform (RegReal hreg) slot + insn <- loadR (RegReal hreg) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- COMMENT (fsLit "spill load") : -} insn : spills -loadTemp _ _ _ _ spills = +loadTemp _ _ _ spills = return spills diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs index ea05cf0d0f..b1fc3c169e 100644 --- a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs +++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs @@ -28,8 +28,8 @@ where import RegAlloc.Linear.FreeRegs +import DynFlags import Outputable -import Platform import UniqFM import Unique @@ -47,8 +47,8 @@ data StackMap -- | An empty stack map, with all slots available. -emptyStackMap :: Platform -> StackMap -emptyStackMap platform = StackMap [0 .. maxSpillSlots platform] emptyUFM +emptyStackMap :: DynFlags -> StackMap +emptyStackMap dflags = StackMap [0 .. maxSpillSlots dflags] emptyUFM -- | If this vreg unique already has a stack assignment then return the slot number, diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs index ca2ecd3883..a608a947e7 100644 --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -1,39 +1,31 @@ -- | State monad for the linear register allocator. --- Here we keep all the state that the register allocator keeps track --- of as it walks the instructions in a basic block. - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details +-- Here we keep all the state that the register allocator keeps track +-- of as it walks the instructions in a basic block. module RegAlloc.Linear.State ( - RA_State(..), - RegM, - runR, - - spillR, - loadR, - - getFreeRegsR, - setFreeRegsR, - - getAssigR, - setAssigR, - - getBlockAssigR, - setBlockAssigR, - - setDeltaR, - getDeltaR, - - getUniqueR, - - recordSpill + RA_State(..), + RegM, + runR, + + spillR, + loadR, + + getFreeRegsR, + setFreeRegsR, + + getAssigR, + setAssigR, + + getBlockAssigR, + setBlockAssigR, + + setDeltaR, + getDeltaR, + + getUniqueR, + + recordSpill ) where @@ -44,67 +36,79 @@ import RegAlloc.Liveness import Instruction import Reg -import Platform +import DynFlags import Unique import UniqSupply +-- | The register allocator monad type. +newtype RegM freeRegs a + = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) } + + -- | The RegM Monad instance Monad (RegM freeRegs) where m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s } return a = RegM $ \s -> (# s, a #) +instance HasDynFlags (RegM a) where + getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #) + -- | Run a computation in the RegM register allocator monad. -runR :: BlockAssignment freeRegs - -> freeRegs - -> RegMap Loc - -> StackMap - -> UniqSupply - -> RegM freeRegs a - -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a) - -runR block_assig freeregs assig stack us thing = - case unReg thing - (RA_State - { ra_blockassig = block_assig - , ra_freeregs = freeregs - , ra_assig = assig - , ra_delta = 0{-???-} - , ra_stack = stack - , ra_us = us - , ra_spills = [] }) +runR :: DynFlags + -> BlockAssignment freeRegs + -> freeRegs + -> RegMap Loc + -> StackMap + -> UniqSupply + -> RegM freeRegs a + -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a) + +runR dflags block_assig freeregs assig stack us thing = + case unReg thing + (RA_State + { ra_blockassig = block_assig + , ra_freeregs = freeregs + , ra_assig = assig + , ra_delta = 0{-???-} + , ra_stack = stack + , ra_us = us + , ra_spills = [] + , ra_DynFlags = dflags }) of - (# state'@RA_State - { ra_blockassig = block_assig - , ra_stack = stack' } - , returned_thing #) - - -> (block_assig, stack', makeRAStats state', returned_thing) + (# state'@RA_State + { ra_blockassig = block_assig + , ra_stack = stack' } + , returned_thing #) + + -> (block_assig, stack', makeRAStats state', returned_thing) -- | Make register allocator stats from its final state. makeRAStats :: RA_State freeRegs -> RegAllocStats makeRAStats state - = RegAllocStats - { ra_spillInstrs = binSpillReasons (ra_spills state) } + = RegAllocStats + { ra_spillInstrs = binSpillReasons (ra_spills state) } spillR :: Instruction instr - => Platform -> Reg -> Unique -> RegM freeRegs (instr, Int) + => Reg -> Unique -> RegM freeRegs (instr, Int) -spillR platform reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> - let (stack',slot) = getStackSlotFor stack temp - instr = mkSpillInstr platform reg delta slot +spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> + let dflags = ra_DynFlags s + (stack',slot) = getStackSlotFor stack temp + instr = mkSpillInstr dflags reg delta slot in (# s{ra_stack=stack'}, (instr,slot) #) loadR :: Instruction instr - => Platform -> Reg -> Int -> RegM freeRegs instr + => Reg -> Int -> RegM freeRegs instr -loadR platform reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> - (# s, mkLoadInstr platform reg delta slot #) +loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> + let dflags = ra_DynFlags s + in (# s, mkLoadInstr dflags reg delta slot #) getFreeRegsR :: RegM freeRegs freeRegs getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> @@ -146,4 +150,5 @@ getUniqueR = RegM $ \s -> -- | Record that a spill instruction was inserted, for profiling. recordSpill :: SpillReason -> RegM freeRegs () recordSpill spill - = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #) + = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #) + diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs index 6309b24b45..0fcd658120 100644 --- a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs @@ -1,5 +1,5 @@ --- | Free regs map for i386 and x86_64 +-- | Free regs map for i386 module RegAlloc.Linear.X86.FreeRegs where @@ -12,29 +12,25 @@ import Platform import Data.Word import Data.Bits -type FreeRegs -#ifdef i386_TARGET_ARCH - = Word32 -#else - = Word64 -#endif +newtype FreeRegs = FreeRegs Word32 + deriving Show noFreeRegs :: FreeRegs -noFreeRegs = 0 +noFreeRegs = FreeRegs 0 releaseReg :: RealReg -> FreeRegs -> FreeRegs -releaseReg (RealRegSingle n) f - = f .|. (1 `shiftL` n) +releaseReg (RealRegSingle n) (FreeRegs f) + = FreeRegs (f .|. (1 `shiftL` n)) releaseReg _ _ - = panic "RegAlloc.Linear.X86.FreeRegs.realeaseReg: no reg" + = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg" initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldr releaseReg noFreeRegs (allocatableRegs platform) -getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazilly -getFreeRegs platform cls f = go f 0 +getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs platform cls (FreeRegs f) = go f 0 where go 0 _ = [] go n m @@ -47,10 +43,9 @@ getFreeRegs platform cls f = go f 0 -- in order to find a floating-point one. allocateReg :: RealReg -> FreeRegs -> FreeRegs -allocateReg (RealRegSingle r) f - = f .&. complement (1 `shiftL` r) +allocateReg (RealRegSingle r) (FreeRegs f) + = FreeRegs (f .&. complement (1 `shiftL` r)) allocateReg _ _ = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg" - diff --git a/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs new file mode 100644 index 0000000000..c04fce9645 --- /dev/null +++ b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs @@ -0,0 +1,52 @@ + +-- | Free regs map for x86_64 +module RegAlloc.Linear.X86_64.FreeRegs +where + +import X86.Regs +import RegClass +import Reg +import Panic +import Platform + +import Data.Word +import Data.Bits + +newtype FreeRegs = FreeRegs Word64 + deriving Show + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 + +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle n) (FreeRegs f) + = FreeRegs (f .|. (1 `shiftL` n)) + +releaseReg _ _ + = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg" + +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform + = foldr releaseReg noFreeRegs (allocatableRegs platform) + +getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily +getFreeRegs platform cls (FreeRegs f) = go f 0 + + where go 0 _ = [] + go n m + | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls + = RealRegSingle m : (go (n `shiftR` 1) $! (m+1)) + + | otherwise + = go (n `shiftR` 1) $! (m+1) + -- ToDo: there's no point looking through all the integer registers + -- in order to find a floating-point one. + +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs f) + = FreeRegs (f .&. complement (1 `shiftL` r)) + +allocateReg _ _ + = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg" + + |