projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Follow Digraph changes in RegAllocLinear.hs
[ghc-hetmet.git]
/
compiler
/
nativeGen
/
RegAllocLinear.hs
diff --git
a/compiler/nativeGen/RegAllocLinear.hs
b/compiler/nativeGen/RegAllocLinear.hs
index
c3a7319
..
918d7c6
100644
(file)
--- a/
compiler/nativeGen/RegAllocLinear.hs
+++ b/
compiler/nativeGen/RegAllocLinear.hs
@@
-1,3
+1,4
@@
+{-# OPTIONS -fno-warn-missing-signatures #-}
-----------------------------------------------------------------------------
--
-- The register allocator
-----------------------------------------------------------------------------
--
-- The register allocator
@@
-5,7
+6,6
@@
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------
-{-# OPTIONS -fno-warn-missing-signatures #-}
{-
The algorithm is roughly:
{-
The algorithm is roughly:
@@
-88,11
+88,12
@@
module RegAllocLinear (
#include "HsVersions.h"
#include "HsVersions.h"
+import BlockId
import MachRegs
import MachInstrs
import RegAllocInfo
import RegLiveness
import MachRegs
import MachInstrs
import RegAllocInfo
import RegLiveness
-import Cmm
+import Cmm hiding (RegSet)
import Digraph
import Unique ( Uniquable(getUnique), Unique )
import Digraph
import Unique ( Uniquable(getUnique), Unique )
@@
-101,12
+102,11
@@
import UniqFM
import UniqSupply
import Outputable
import State
import UniqSupply
import Outputable
import State
+import FastString
-#ifndef DEBUG
-import Data.Maybe ( fromJust )
-#endif
-import Data.List ( nub, partition, foldl')
-import Control.Monad ( when )
+import Data.Maybe
+import Data.List
+import Control.Monad
import Data.Word
import Data.Bits
import Data.Word
import Data.Bits
@@
-157,8
+157,9
@@
getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly
getFreeRegs cls (FreeRegs g f)
| RcDouble <- cls = go f (0x80000000) 63
| RcInteger <- cls = go g (0x80000000) 31
getFreeRegs cls (FreeRegs g f)
| RcDouble <- cls = go f (0x80000000) 63
| RcInteger <- cls = go g (0x80000000) 31
+ | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad cls" (ppr cls)
where
where
- go x 0 i = []
+ go _ 0 _ = []
go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
| otherwise = go x (m `shiftR` 1) $! i-1
go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
| otherwise = go x (m `shiftR` 1) $! i-1
@@
-223,7
+224,9
@@
emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM
getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
getStackSlotFor (StackMap [] _) _
getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
getStackSlotFor (StackMap [] _) _
- = panic "RegAllocLinear.getStackSlotFor: out of stack slots"
+ = panic "RegAllocLinear.getStackSlotFor: out of stack slots, try -fregs-graph"
+ -- This happens with darcs' SHA1.hs, see #1993
+
getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
case lookupUFM reserved reg of
Just slot -> (fs,slot)
getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
case lookupUFM reserved reg of
Just slot -> (fs,slot)
@@
-242,12
+245,12
@@
regAlloc (CmmData sec d)
( CmmData sec d
, Nothing )
( CmmData sec d
, Nothing )
-regAlloc (CmmProc (LiveInfo info _ _) lbl params [])
+regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
= return
= return
- ( CmmProc info lbl params []
+ ( CmmProc info lbl params (ListGraph [])
, Nothing )
, Nothing )
-regAlloc (CmmProc static lbl params comps)
+regAlloc (CmmProc static lbl params (ListGraph comps))
| LiveInfo info (Just first_id) block_live <- static
= do
-- do register allocation on each component.
| LiveInfo info (Just first_id) block_live <- static
= do
-- do register allocation on each component.
@@
-263,7
+266,7
@@
regAlloc (CmmProc static lbl params comps)
let ((first':_), rest')
= partition ((== first_id) . blockId) final_blocks
let ((first':_), rest')
= partition ((== first_id) . blockId) final_blocks
- return ( CmmProc info lbl params (first' : rest')
+ return ( CmmProc info lbl params (ListGraph (first' : rest'))
, Just stats)
-- bogus. to make non-exhaustive match warning go away.
, Just stats)
-- bogus. to make non-exhaustive match warning go away.
@@
-292,10
+295,8
@@
save it in a spill location, but mark it as InBoth because the current
instruction might still want to read it.
-}
instruction might still want to read it.
-}
-#ifdef DEBUG
instance Outputable Loc where
ppr l = text (show l)
instance Outputable Loc where
ppr l = text (show l)
-#endif
-- | Do register allocation on some basic blocks.
-- | Do register allocation on some basic blocks.
@@
-575,7
+576,7
@@
saveClobberedTemps clobbered dying = do
recordSpill (SpillClobber temp)
let new_assign = addToUFM assig temp (InBoth reg slot)
recordSpill (SpillClobber temp)
let new_assign = addToUFM assig temp (InBoth reg slot)
- clobber new_assign (spill : COMMENT FSLIT("spill clobber") : instrs) rest
+ clobber new_assign (spill : COMMENT (fsLit "spill clobber") : instrs) rest
clobberRegs :: [RegNo] -> RegM ()
clobberRegs [] = return () -- common case
clobberRegs :: [RegNo] -> RegM ()
clobberRegs [] = return () -- common case
@@
-692,7
+693,7
@@
allocateRegsAndSpill reading keep spills alloc (r:rs) = do
(spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out
let spill_store = (if reading then id else reverse)
(spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out
let spill_store = (if reading then id else reverse)
- [ COMMENT FSLIT("spill alloc")
+ [ COMMENT (fsLit "spill alloc")
, spill_insn ]
-- record that this temp was spilled
, spill_insn ]
-- record that this temp was spilled
@@
-724,7
+725,7
@@
loadTemp True vreg (Just (InMem slot)) hreg spills
= do
insn <- loadR (RealReg hreg) slot
recordSpill (SpillLoad $ getUnique vreg)
= do
insn <- loadR (RealReg hreg) slot
recordSpill (SpillLoad $ getUnique vreg)
- return $ COMMENT FSLIT("spill load") : insn : spills
+ return $ COMMENT (fsLit "spill load") : insn : spills
loadTemp _ _ _ _ spills =
return spills
loadTemp _ _ _ _ spills =
return spills
@@
-796,7
+797,7
@@
joinToTargets block_live new_blocks instr (dest:dests) = do
delta <- getDeltaR
let graph = makeRegMovementGraph adjusted_assig dest_assig
delta <- getDeltaR
let graph = makeRegMovementGraph adjusted_assig dest_assig
- let sccs = stronglyConnCompR graph
+ let sccs = stronglyConnCompFromEdgedVerticesR graph
fixUpInstrs <- mapM (handleComponent delta instr) sccs
block_id <- getUniqueR
fixUpInstrs <- mapM (handleComponent delta instr) sccs
block_id <- getUniqueR
@@
-808,7
+809,7
@@
joinToTargets block_live new_blocks instr (dest:dests) = do
joinToTargets block_live (block : new_blocks) instr' dests
joinToTargets block_live (block : new_blocks) instr' dests
--- | Construct a graph of register/spill movements.
+-- | Construct a graph of register\/spill movements.
--
-- We cut some corners by
-- a) not handling cyclic components
--
-- We cut some corners by
-- a) not handling cyclic components
@@
-826,7
+827,7
@@
makeRegMovementGraph adjusted_assig dest_assig
= expandNode vreg src
$ lookupWithDefaultUFM_Directly
dest_assig
= expandNode vreg src
$ lookupWithDefaultUFM_Directly
dest_assig
- (panic "RegisterAlloc.joinToTargets")
+ (panic "RegAllocLinear.makeRegMovementGraph")
vreg
in [ node | (vreg, src) <- ufmToList adjusted_assig
vreg
in [ node | (vreg, src) <- ufmToList adjusted_assig
@@
-900,7
+901,7
@@
handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest))
= do
spill_id <- getUniqueR
(_, slot) <- spillR (RealReg sreg) spill_id
= do
spill_id <- getUniqueR
(_, slot) <- spillR (RealReg sreg) spill_id
- remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompR rest)
+ remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest)
restoreAndFixInstr <- getRestoreMoves dsts slot
return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
restoreAndFixInstr <- getRestoreMoves dsts slot
return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
@@
-909,7
+910,7
@@
handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest))
= do
restoreToReg <- loadR (RealReg reg) slot
moveInstr <- makeMove delta vreg r mem
= do
restoreToReg <- loadR (RealReg reg) slot
moveInstr <- makeMove delta vreg r mem
- return $ [COMMENT FSLIT("spill join move"), restoreToReg, moveInstr]
+ return $ [COMMENT (fsLit "spill join move"), restoreToReg, moveInstr]
getRestoreMoves [InReg reg] slot
= loadR (RealReg reg) slot >>= return . (:[])
getRestoreMoves [InReg reg] slot
= loadR (RealReg reg) slot >>= return . (:[])
@@
-1109,12
+1110,9
@@
pprStats code statss
-- -----------------------------------------------------------------------------
-- Utils
-- -----------------------------------------------------------------------------
-- Utils
-#ifdef DEBUG
-my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
-my_fromJust s p (Just x) = x
-#else
-my_fromJust _ _ = fromJust
-#endif
+my_fromJust :: String -> SDoc -> Maybe a -> a
+my_fromJust _ _ (Just x) = x
+my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)
lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)