NCG: Split linear allocator into separate modules.

compiler/nativeGen/AsmCodeGen.lhs

@@ -28,7 +28,9 @@ import NCGMonad
 import PositionIndependentCode
 import RegLiveness
 import RegCoalesce
-import qualified RegAllocLinear	as Linear
+
+import qualified RegAlloc.Linear.Main	as Linear
+
 import qualified RegAllocColor	as Color
 import qualified RegAllocStats	as Color
 import qualified GraphColor	as Color

compiler/nativeGen/RegAlloc/Linear/Base.hs

+
+-- | Put common type definitions here to break recursive module dependencies.
+
+module RegAlloc.Linear.Base (
+	BlockAssignment,
+	Loc(..),
+
+	-- for stats
+	SpillReason(..),
+	RegAllocStats(..),
+	
+	-- the allocator monad
+	RA_State(..),
+	RegM(..)
+)
+
+where
+
+import RegAlloc.Linear.FreeRegs
+import RegAlloc.Linear.StackMap
+
+import RegLiveness
+import MachRegs
+
+import Outputable
+import Unique
+import UniqFM
+import UniqSupply
+
+
+-- | Used to store the register assignment on entry to a basic block.
+--	We use this to handle join points, where multiple branch instructions
+--	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)
+
+
+-- | Where a vreg is currently stored
+--	A temporary can be marked as living in both a register and memory
+--	(InBoth), for example if it was recently loaded from a spill location.
+--	This makes it cheap to spill (no save instruction required), but we
+--	have to be careful to turn this into InReg if the value in the
+--	register is changed.
+
+--	This is also useful when a temporary is about to be clobbered.  We
+--	save it in a spill location, but mark it as InBoth because the current
+--	instruction might still want to read it.
+--
+data Loc 
+	-- | vreg is in a register
+	= InReg   {-# UNPACK #-} !RegNo
+
+	-- | vreg is held in a stack slot
+	| InMem   {-# UNPACK #-} !StackSlot
+
+
+	-- | vreg is held in both a register and a stack slot
+	| InBoth  {-# UNPACK #-}  !RegNo
+		   {-# UNPACK #-} !StackSlot
+	deriving (Eq, Show, Ord)
+
+instance Outputable Loc where
+	ppr l = text (show l)
+
+
+-- | Reasons why instructions might be inserted by the spiller.
+--	Used when generating stats for -ddrop-asm-stats.
+--
+data SpillReason
+	-- | vreg was spilled to a slot so we could use its
+	--	current hreg for another vreg
+	= SpillAlloc	!Unique	
+
+	-- | vreg was moved because its hreg was clobbered
+	| SpillClobber	!Unique	
+
+	-- | vreg was loaded from a spill slot
+	| SpillLoad	!Unique	
+
+	-- | reg-reg move inserted during join to targets
+	| SpillJoinRR	!Unique	
+
+	-- | reg-mem move inserted during join to targets
+	| SpillJoinRM	!Unique	
+
+
+-- | Used to carry interesting stats out of the register allocator.
+data RegAllocStats
+	= RegAllocStats
+	{ ra_spillInstrs	:: UniqFM [Int] }
+
+
+-- | The register alloctor state
+data RA_State 
+	= RA_State 
+
+	-- | the current mapping from basic blocks to 
+	-- 	the register assignments at the beginning of that block.
+	{ ra_blockassig	:: BlockAssignment
+	
+	-- | free machine registers
+	, ra_freeregs   :: {-#UNPACK#-}!FreeRegs
+
+	-- | assignment of temps to locations
+	, ra_assig      :: RegMap Loc
+
+	-- | current stack delta
+	, ra_delta      :: Int
+
+	-- | free stack slots for spilling
+	, ra_stack      :: StackMap
+
+	-- | unique supply for generating names for join point fixup blocks.
+	, ra_us         :: UniqSupply
+
+	-- | 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 a 
+	= RegM { unReg :: RA_State -> (# RA_State, a #) }
+
+

compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs

+
+module RegAlloc.Linear.FreeRegs (
+	FreeRegs(),
+	noFreeRegs,
+	releaseReg,
+	initFreeRegs,
+	getFreeRegs,
+	allocateReg
+)
+
+#include "HsVersions.h"
+
+where
+
+-- -----------------------------------------------------------------------------
+-- The free register set
+-- This needs to be *efficient*
+-- Here's an inefficient 'executable specification' of the FreeRegs data type:
+--
+--	type FreeRegs = [RegNo]
+--	noFreeRegs = 0
+--	releaseReg n f = if n `elem` f then f else (n : f)
+--	initFreeRegs = allocatableRegs
+--	getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
+--	allocateReg f r = filter (/= r) f
+
+
+#if   defined(powerpc_TARGET_ARCH) 
+import RegAlloc.Linear.PPC.FreeRegs
+
+#elif defined(sparc_TARGET_ARCH)
+import RegAlloc.Linear.SPARC.FreeRegs
+
+#elif defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH)
+import RegAlloc.Linear.X86.FreeRegs
+
+#else
+#error "RegAlloc.Linear.FreeRegs not defined for this architecture."
+
+#endif
+

compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs

+
+-- | Free regs map for PowerPC
+module RegAlloc.Linear.PPC.FreeRegs
+where
+
+import MachRegs
+
+import Outputable
+
+import Data.Word
+import Data.Bits
+import Data.List
+
+-- The PowerPC has 32 integer and 32 floating point registers.
+-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
+-- better.
+-- Note that when getFreeRegs scans for free registers, it starts at register
+-- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
+-- registers are callee-saves, while the lower regs are caller-saves, so it
+-- makes sense to start at the high end.
+-- Apart from that, the code does nothing PowerPC-specific, so feel free to
+-- add your favourite platform to the #if (if you have 64 registers but only
+-- 32-bit words).
+
+data FreeRegs = FreeRegs !Word32 !Word32
+	      deriving( Show )	-- The Show is used in an ASSERT
+
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0 0
+
+releaseReg :: RegNo -> FreeRegs -> FreeRegs
+releaseReg r (FreeRegs g f)
+    | r > 31    = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32)))
+    | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f
+    
+initFreeRegs :: FreeRegs
+initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
+
+getFreeRegs :: RegClass -> FreeRegs -> [RegNo]	-- lazilly
+getFreeRegs cls (FreeRegs g f)
+    | RcDouble <- cls = go f (0x80000000) 63
+    | RcInteger <- cls = go g (0x80000000) 31
+    | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls)
+    where
+        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
+
+allocateReg :: RegNo -> FreeRegs -> FreeRegs
+allocateReg r (FreeRegs g f) 
+    | r > 31    = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32)))
+    | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f
+
+

compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs

+
+-- | Free regs map for SPARC
+module RegAlloc.Linear.SPARC.FreeRegs
+where
+
+import MachRegs
+
+import Outputable
+
+import Data.Word
+import Data.Bits
+import Data.List
+
+--------------------------------------------------------------------------------
+-- SPARC is like PPC, except for twinning of floating point regs.
+--	When we allocate a double reg we must take an even numbered
+--	float reg, as well as the one after it.
+
+
+-- Holds bitmaps showing what registers are currently allocated.
+--	The float and double reg bitmaps overlap, but we only alloc
+--	float regs into the float map, and double regs into the double map.
+--
+--	Free regs have a bit set in the corresponding bitmap.
+--
+data FreeRegs 
+	= FreeRegs 
+		!Word32 	-- int    reg bitmap	regs  0..31
+		!Word32 	-- float  reg bitmap	regs 32..63
+		!Word32		-- double reg bitmap	regs 32..63
+	deriving( Show )
+
+
+-- | A reg map where no regs are free to be allocated.
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0 0 0
+
+
+-- | The initial set of free regs.
+--	Don't treat the top half of reg pairs we're using as doubles as being free.
+initFreeRegs :: FreeRegs
+initFreeRegs 
+ = 	regs
+ where	
+--	freeDouble	= getFreeRegs RcDouble regs
+	regs		= foldr releaseReg noFreeRegs allocable
+	allocable	= allocatableRegs \\ doublePairs
+	doublePairs	= [43, 45, 47, 49, 51, 53]
+
+			
+-- | Get all the free registers of this class.
+getFreeRegs :: RegClass -> FreeRegs -> [RegNo]	-- lazilly
+getFreeRegs cls (FreeRegs g f d)
+	| RcInteger <- cls = go g 1 0
+	| RcFloat   <- cls = go f 1 32
+	| RcDouble  <- cls = go d 1 32
+	| otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)
+	where
+		go _ 0 _ = []
+	        go x m i | x .&. m /= 0 = i : (go x (m `shiftL` 1) $! i+1)
+        	         | otherwise    = go x (m `shiftL` 1) $! i+1
+{-
+showFreeRegs :: FreeRegs -> String
+showFreeRegs regs
+ 	=  "FreeRegs\n"
+	++ "    integer: " ++ (show $ getFreeRegs RcInteger regs)	++ "\n"
+	++ "      float: " ++ (show $ getFreeRegs RcFloat   regs)	++ "\n"
+	++ "     double: " ++ (show $ getFreeRegs RcDouble  regs)	++ "\n"
+-}
+
+{-
+-- | Check whether a reg is free
+regIsFree :: RegNo -> FreeRegs -> Bool
+regIsFree r (FreeRegs g f d)
+
+	-- a general purpose reg
+	| r <= 31	
+	, mask	<- 1 `shiftL` fromIntegral r
+	= g .&. mask /= 0
+
+	-- use the first 22 float regs as double precision
+	| r >= 32
+	, r <= 53
+	, mask	<- 1 `shiftL` (fromIntegral r - 32)
+	= d .&. mask /= 0
+
+	-- use the last 10 float regs as single precision
+	| otherwise 
+	, mask	<- 1 `shiftL` (fromIntegral r - 32)
+	= f .&. mask /= 0
+-}
+
+-- | Grab a register.
+grabReg :: RegNo -> FreeRegs -> FreeRegs
+grabReg r (FreeRegs g f d)
+
+	-- a general purpose reg
+	| r <= 31
+	, mask	<- complement (1 `shiftL` fromIntegral r)
+	= FreeRegs (g .&. mask) f d
+    
+	-- use the first 22 float regs as double precision
+	| r >= 32
+	, r <= 53
+	, mask	<- complement (1 `shiftL` (fromIntegral r - 32))
+	= FreeRegs g f (d .&. mask)
+
+	-- use the last 10 float regs as single precision
+	| otherwise
+	, mask	<- complement (1 `shiftL` (fromIntegral r - 32))
+	= FreeRegs g (f .&. mask) d
+
+
+
+-- | Release a register from allocation.
+--	The register liveness information says that most regs die after a C call, 
+--	but we still don't want to allocate to some of them.
+--
+releaseReg :: RegNo -> FreeRegs -> FreeRegs
+releaseReg r regs@(FreeRegs g f d)
+
+	-- used by STG machine, or otherwise unavailable
+	| r >= 0  && r <= 15	= regs
+--	| r >= 3  && r <= 15	= regs
+
+	| r >= 17 && r <= 21	= regs
+	| r >= 24 && r <= 31	= regs
+	| r >= 32 && r <= 41	= regs
+	| r >= 54 && r <= 59	= regs
+
+	-- never release the high part of double regs.
+	| r == 43		= regs
+	| r == 45		= regs
+	| r == 47		= regs
+	| r == 49		= regs
+	| r == 51		= regs
+	| r == 53		= regs
+	
+	-- a general purpose reg
+	| r <= 31	
+	, mask	<- 1 `shiftL` fromIntegral r
+	= FreeRegs (g .|. mask) f d
+
+	-- use the first 22 float regs as double precision
+	| r >= 32
+	, r <= 53
+	, mask	<- 1 `shiftL` (fromIntegral r - 32)
+	= FreeRegs g f (d .|. mask)
+
+	-- use the last 10 float regs as single precision
+	| otherwise 
+	, mask	<- 1 `shiftL` (fromIntegral r - 32)
+	= FreeRegs g (f .|. mask) d
+
+
+-- | Allocate a register in the map.
+allocateReg :: RegNo -> FreeRegs -> FreeRegs
+allocateReg r regs -- (FreeRegs g f d) 
+
+	-- if the reg isn't actually free then we're in trouble
+{-	| not $ regIsFree r regs
+	= pprPanic 
+		"RegAllocLinear.allocateReg"
+		(text "reg " <> ppr r <> text " is not free")
+-}  
+	| otherwise
+	= grabReg r regs
+

compiler/nativeGen/RegAlloc/Linear/StackMap.hs

+
+-- | The assignment of virtual registers to stack slots
+
+-- 	We have lots of stack slots. Memory-to-memory moves are a pain on most
+-- 	architectures. Therefore, we avoid having to generate memory-to-memory moves
+-- 	by simply giving every virtual register its own stack slot.
+
+-- 	The StackMap stack map keeps track of virtual register - stack slot
+-- 	associations and of which stack slots are still free. Once it has been
+-- 	associated, a stack slot is never "freed" or removed from the StackMap again,
+-- 	it remains associated until we are done with the current CmmProc.
+--
+module RegAlloc.Linear.StackMap (
+	StackSlot,
+	StackMap(..),
+	emptyStackMap,
+	getStackSlotFor
+)
+
+where
+
+import RegAllocInfo	(maxSpillSlots)
+
+import Outputable
+import UniqFM
+import Unique
+
+
+-- | Identifier for a stack slot.
+type StackSlot = Int
+
+data StackMap 
+	= StackMap 
+
+	-- | The slots that are still available to be allocated.
+	{ stackMapFreeSlots	:: [StackSlot]
+
+	-- | Assignment of vregs to stack slots.
+	, stackMapAssignment	:: UniqFM StackSlot }
+
+
+-- | An empty stack map, with all slots available.
+emptyStackMap :: StackMap
+emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM
+
+
+-- | If this vreg unique already has a stack assignment then return the slot number,
+--	otherwise allocate a new slot, and update the map.
+--
+getStackSlotFor :: StackMap -> Unique -> (StackMap, Int)
+
+getStackSlotFor (StackMap [] _) _
+
+        -- This happens all the time when trying to compile darcs' SHA1.hs, see Track #1993
+	--	SHA1.lhs has also been added to the Crypto library on Hackage,
+	--	so we see this all the time.  
+	--
+	-- It would be better to automatically invoke the graph allocator, or do something
+	--	else besides panicing, but that's a job for a different day.  -- BL 2009/02
+	--
+	= panic $   "RegAllocLinear.getStackSlotFor: out of stack slots\n"
+		++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"
+		++  "   is a known limitation in the linear allocator.\n"
+		++  "\n"
+		++  "   Try enabling the graph colouring allocator with -fregs-graph instead."
+		++  "   You can still file a bug report if you like.\n"
+		
+getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
+    case lookupUFM reserved reg of
+    	Just slot	-> (fs, slot)
+    	Nothing		-> (StackMap stack' (addToUFM reserved reg freeSlot), freeSlot)
+

compiler/nativeGen/RegAlloc/Linear/State.hs

+-- | 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.
+
+module RegAlloc.Linear.State (
+	RA_State(..),
+	RegM,
+	runR,
+
+	spillR,
+	loadR,
+
+	getFreeRegsR,
+	setFreeRegsR,
+
+	getAssigR,
+	setAssigR,
+	
+	getBlockAssigR,
+	setBlockAssigR,
+	
+	setDeltaR,
+	getDeltaR,
+	
+	getUniqueR,
+	
+	recordSpill
+)
+where
+
+import RegAlloc.Linear.Stats
+import RegAlloc.Linear.StackMap
+import RegAlloc.Linear.Base
+import RegAlloc.Linear.FreeRegs
+
+
+import MachInstrs
+import MachRegs
+import RegAllocInfo
+import RegLiveness
+
+import Unique
+import UniqSupply
+
+
+-- | The RegM Monad
+instance Monad RegM where
+  m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
+  return a  =  RegM $ \s -> (# s, a #)
+
+
+-- | Run a computation in the RegM register allocator monad.
+runR 	:: BlockAssignment 
+	-> FreeRegs 
+	-> RegMap Loc
+	-> StackMap 
+	-> UniqSupply
+  	-> RegM a 
+	-> (BlockAssignment, 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 	= [] }) 
+   of
+	(# 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 -> RegAllocStats
+makeRAStats state
+	= RegAllocStats
+	{ ra_spillInstrs	= binSpillReasons (ra_spills state) }
+
+
+spillR :: Reg -> Unique -> RegM (Instr, Int)
+spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
+  let (stack',slot) = getStackSlotFor stack temp
+      instr  = mkSpillInstr reg delta slot
+  in
+  (# s{ra_stack=stack'}, (instr,slot) #)
+
+loadR :: Reg -> Int -> RegM Instr
+loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
+  (# s, mkLoadInstr reg delta slot #)
+
+getFreeRegsR :: RegM FreeRegs
+getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
+  (# s, freeregs #)
+
+setFreeRegsR :: FreeRegs -> RegM ()
+setFreeRegsR regs = RegM $ \ s ->
+  (# s{ra_freeregs = regs}, () #)
+
+getAssigR :: RegM (RegMap Loc)
+getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
+  (# s, assig #)
+
+setAssigR :: RegMap Loc -> RegM ()
+setAssigR assig = RegM $ \ s ->
+  (# s{ra_assig=assig}, () #)
+
+getBlockAssigR :: RegM BlockAssignment
+getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
+  (# s, assig #)
+
+setBlockAssigR :: BlockAssignment -> RegM ()
+setBlockAssigR assig = RegM $ \ s ->
+  (# s{ra_blockassig = assig}, () #)
+
+setDeltaR :: Int -> RegM ()
+setDeltaR n = RegM $ \ s ->
+  (# s{ra_delta = n}, () #)
+
+getDeltaR :: RegM Int
+getDeltaR = RegM $ \s -> (# s, ra_delta s #)
+
+getUniqueR :: RegM Unique
+getUniqueR = RegM $ \s ->
+  case splitUniqSupply (ra_us s) of
+    (us1, us2) -> (# s{ra_us = us2}, uniqFromSupply us1 #)
+
+
+-- | Record that a spill instruction was inserted, for profiling.
+recordSpill :: SpillReason -> RegM ()
+recordSpill spill
+ 	= RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)

compiler/nativeGen/RegAlloc/Linear/Stats.hs

+module RegAlloc.Linear.Stats (
+	binSpillReasons,
+	countRegRegMovesNat,
+	pprStats
+)
+
+where
+
+import RegAlloc.Linear.Base
+import RegLiveness
+import RegAllocInfo
+import MachInstrs
+import Cmm		(GenBasicBlock(..))
+
+import UniqFM
+import Outputable
+
+import Data.List
+import State
+
+-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
+binSpillReasons
+	:: [SpillReason] -> UniqFM [Int]
+
+binSpillReasons reasons
+	= addListToUFM_C
+		(zipWith (+))
+		emptyUFM
+		(map (\reason -> case reason of
+			SpillAlloc r	-> (r, [1, 0, 0, 0, 0])
+			SpillClobber r	-> (r, [0, 1, 0, 0, 0])
+			SpillLoad r	-> (r, [0, 0, 1, 0, 0])
+			SpillJoinRR r	-> (r, [0, 0, 0, 1, 0])
+			SpillJoinRM r	-> (r, [0, 0, 0, 0, 1])) reasons)
+
+
+-- | Count reg-reg moves remaining in this code.
+countRegRegMovesNat :: NatCmmTop -> Int
+countRegRegMovesNat cmm
+	= execState (mapGenBlockTopM countBlock cmm) 0
+ where
+ 	countBlock b@(BasicBlock _ instrs)
+	 = do	mapM_ countInstr instrs
+	 	return	b
+
+	countInstr instr
+		| Just _	<- isRegRegMove instr
+		= do	modify (+ 1)
+			return instr
+
+		| otherwise
+		=	return instr
+
+
+-- | Pretty print some RegAllocStats
+pprStats :: [NatCmmTop] -> [RegAllocStats] -> SDoc
+pprStats code statss
+ = let	-- sum up all the instrs inserted by the spiller
+ 	spills		= foldl' (plusUFM_C (zipWith (+)))
+ 				emptyUFM
+			$ map ra_spillInstrs statss
+
+	spillTotals	= foldl' (zipWith (+))
+				[0, 0, 0, 0, 0]
+			$ eltsUFM spills
+
+	-- count how many reg-reg-moves remain in the code
+	moves		= sum $ map countRegRegMovesNat code
+
+	pprSpill (reg, spills)
+		= parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))
+
+   in	(  text "-- spills-added-total"
+	$$ text "--    (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"
+	$$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves])))
+	$$ text ""
+	$$ text "-- spills-added"
+   	$$ text "--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
+	$$ (vcat $ map pprSpill
+   		 $ ufmToList spills)
+	$$ text "")
+