Remove CPP from nativeGen/RegAlloc/Linear/FreeRegs.hs

Fixes more failures on arches without an NCG

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index c7ea591..ae91b62 100644 (file)
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -424,7 +424,7 @@ cmmNativeGen dflags ncgImpl us cmm count
                        = {-# SCC "RegAlloc" #-}
                          initUs usLive
                          $ liftM unzip
                        = {-# SCC "RegAlloc" #-}
                          initUs usLive
                          $ liftM unzip

-                         $ mapUs Linear.regAlloc withLiveness
+                         $ mapUs (Linear.regAlloc dflags) withLiveness

 
                dumpIfSet_dyn dflags
                        Opt_D_dump_asm_regalloc "Registers allocated"
 
                dumpIfSet_dyn dflags
                        Opt_D_dump_asm_regalloc "Registers allocated"

diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs
index fc8d4ed..432acdf 100644 (file)
--- a/compiler/nativeGen/RegAlloc/Linear/Base.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs
@@ -18,7 +18,6 @@ module RegAlloc.Linear.Base (
 
 where
 
 
 where
 

-import RegAlloc.Linear.FreeRegs

 import RegAlloc.Linear.StackMap
 import RegAlloc.Liveness
 import Reg
 import RegAlloc.Linear.StackMap
 import RegAlloc.Liveness
 import Reg

@@ -34,8 +33,8 @@ import UniqSupply
 --      target a particular label. We have to insert fixup code to make
 --      the register assignments from the different sources match up.
 --
 --      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)
+type BlockAssignment freeRegs
+        = BlockMap (freeRegs, RegMap Loc)

 
 
 -- | Where a vreg is currently stored
 
 
 -- | Where a vreg is currently stored

@@ -107,7 +106,7 @@ data RA_State freeRegs
         {
         -- | the current mapping from basic blocks to
         --      the register assignments at the beginning of that block.
         {
         -- | the current mapping from basic blocks to
         --      the register assignments at the beginning of that block.

-          ra_blockassig :: BlockAssignment
+          ra_blockassig :: BlockAssignment freeRegs

 
         -- | free machine registers
         , ra_freeregs   :: !freeRegs
 
         -- | free machine registers
         , ra_freeregs   :: !freeRegs

diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
index b357160..b442d06 100644 (file)
--- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
@@ -1,18 +1,19 @@
 
 module RegAlloc.Linear.FreeRegs (
 
 module RegAlloc.Linear.FreeRegs (

-       FreeRegs(),
-       noFreeRegs,
-       releaseReg,
-       initFreeRegs,
-       getFreeRegs,
-       allocateReg,
-       maxSpillSlots
+    FR(..),
+    maxSpillSlots

 )
 
 #include "HsVersions.h"
 
 where
 
 )
 
 #include "HsVersions.h"
 
 where
 

+import Reg
+import RegClass
+
+import Panic
+import Platform
+

 -- -----------------------------------------------------------------------------
 -- The free register set
 -- This needs to be *efficient*
 -- -----------------------------------------------------------------------------
 -- The free register set
 -- This needs to be *efficient*

@@ -25,21 +26,48 @@ where
 --     getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
 --     allocateReg f r = filter (/= r) f
 
 --     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 PPC.Instr
+import qualified SPARC.Instr
+import qualified X86.Instr
+
+class Show freeRegs => FR freeRegs where
+    frAllocateReg :: RealReg -> freeRegs -> freeRegs
+    frGetFreeRegs :: RegClass -> freeRegs -> [RealReg]
+    frInitFreeRegs :: freeRegs
+    frReleaseReg :: RealReg -> freeRegs -> freeRegs

 
 

-#if   defined(powerpc_TARGET_ARCH) 
-import RegAlloc.Linear.PPC.FreeRegs
-import PPC.Instr       (maxSpillSlots)
+instance FR X86.FreeRegs where
+    frAllocateReg  = X86.allocateReg
+    frGetFreeRegs  = X86.getFreeRegs
+    frInitFreeRegs = X86.initFreeRegs
+    frReleaseReg   = X86.releaseReg

 
 

-#elif defined(sparc_TARGET_ARCH)
-import RegAlloc.Linear.SPARC.FreeRegs
-import SPARC.Instr     (maxSpillSlots)
+instance FR PPC.FreeRegs where
+    frAllocateReg  = PPC.allocateReg
+    frGetFreeRegs  = PPC.getFreeRegs
+    frInitFreeRegs = PPC.initFreeRegs
+    frReleaseReg   = PPC.releaseReg

 
 

-#elif defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH)
-import RegAlloc.Linear.X86.FreeRegs
-import X86.Instr       (maxSpillSlots)
+instance FR SPARC.FreeRegs where
+    frAllocateReg  = SPARC.allocateReg
+    frGetFreeRegs  = SPARC.getFreeRegs
+    frInitFreeRegs = SPARC.initFreeRegs
+    frReleaseReg   = SPARC.releaseReg

 
 

-#else
-#error "RegAlloc.Linear.FreeRegs not defined for this architecture."
+-- TODO: We shouldn't be using defaultTargetPlatform here.
+--       We should be passing DynFlags in instead, and looking at
+--       its targetPlatform.

 
 

-#endif
+maxSpillSlots :: Int
+maxSpillSlots = case platformArch defaultTargetPlatform of
+                ArchX86     -> X86.Instr.maxSpillSlots
+                ArchX86_64  -> X86.Instr.maxSpillSlots
+                ArchPPC     -> PPC.Instr.maxSpillSlots
+                ArchSPARC   -> SPARC.Instr.maxSpillSlots
+                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 6a62f07..e6a078a 100644 (file)
--- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS -fno-warn-missing-signatures #-}
-

 
 -- | Handles joining of a jump instruction to its targets.
 
 
 -- | Handles joining of a jump instruction to its targets.
 

@@ -35,14 +33,14 @@ import UniqSet
 --     vregs are in the correct regs for its destination.
 --
 joinToTargets
 --     vregs are in the correct regs for its destination.
 --
 joinToTargets

-       :: Instruction instr
+       :: (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.
 
        => 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.
 

-       -> RegM FreeRegs ([NatBasicBlock instr] --   fresh blocks of fixup code.
+       -> RegM freeRegs ([NatBasicBlock instr] --   fresh blocks of fixup code.

                , instr)                --   the original branch instruction, but maybe patched to jump
                                        --      to a fixup block first.
 
                , instr)                --   the original branch instruction, but maybe patched to jump
                                        --      to a fixup block first.
 

@@ -57,7 +55,7 @@ joinToTargets block_live id instr
 
 -----
 joinToTargets'
 
 -----
 joinToTargets'

-       :: Instruction instr
+       :: (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.
 
        => 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.
 

@@ -68,7 +66,7 @@ joinToTargets'
 
        -> [BlockId]                    -- ^ branch destinations still to consider.
 
 
        -> [BlockId]                    -- ^ branch destinations still to consider.
 

-       -> RegM FreeRegs ( [NatBasicBlock instr]
+       -> RegM freeRegs ( [NatBasicBlock instr]

                , instr)
 
 -- no more targets to consider. all done.
                , instr)
 
 -- no more targets to consider. all done.

@@ -109,13 +107,24 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests)
 
 
 -- this is the first time we jumped to this block.
 
 
 -- this is the first time we jumped to this block.

+joinToTargets_first :: (FR freeRegs, Instruction instr)
+                    => BlockMap RegSet
+                    -> [NatBasicBlock instr]
+                    -> BlockId
+                    -> instr
+                    -> BlockId
+                    -> [BlockId]
+                    -> BlockAssignment freeRegs
+                    -> RegMap Loc
+                    -> [RealReg]
+                    -> RegM freeRegs ([NatBasicBlock instr], instr)

 joinToTargets_first block_live new_blocks block_id instr dest dests
        block_assig src_assig 
 joinToTargets_first block_live new_blocks block_id instr dest dests
        block_assig src_assig 

-       (to_free :: [RealReg])
+       to_free

 
  = do  -- free up the regs that are not live on entry to this block.
        freeregs        <- getFreeRegsR
 
  = do  -- free up the regs that are not live on entry to this block.
        freeregs        <- getFreeRegsR

-       let freeregs'   = foldr releaseReg freeregs to_free 
+       let freeregs'   = foldr frReleaseReg freeregs to_free 

        
        -- remember the current assignment on entry to this block.
        setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig)
        
        -- remember the current assignment on entry to this block.
        setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig)

@@ -124,6 +133,16 @@ joinToTargets_first block_live new_blocks block_id instr dest dests
 
 
 -- we've jumped to this block before
 
 
 -- we've jumped to this block before

+joinToTargets_again :: (Instruction instr, FR freeRegs)
+                    => BlockMap RegSet
+                    -> [NatBasicBlock instr]
+                    -> BlockId
+                    -> instr
+                    -> BlockId
+                    -> [BlockId]
+                    -> UniqFM Loc
+                    -> UniqFM Loc
+                    -> RegM freeRegs ([NatBasicBlock instr], instr)

 joinToTargets_again 
        block_live new_blocks block_id instr dest dests
        src_assig dest_assig
 joinToTargets_again 
        block_live new_blocks block_id instr dest dests
        src_assig dest_assig

@@ -262,7 +281,7 @@ expandNode vreg src dst
 --
 handleComponent 
        :: Instruction instr
 --
 handleComponent 
        :: Instruction instr

-       => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM FreeRegs [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
 
 -- 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

@@ -317,7 +336,7 @@ makeMove
        -> Unique       -- ^ unique of the vreg that we're moving.
        -> Loc          -- ^ source location.
        -> Loc          -- ^ destination location.
        -> Unique       -- ^ unique of the vreg that we're moving.
        -> Loc          -- ^ source location.
        -> Loc          -- ^ destination location.

-       -> RegM FreeRegs instr  -- ^ move instruction.
+       -> RegM freeRegs instr  -- ^ move instruction.

 
 makeMove _     vreg (InReg src) (InReg dst)
  = do  recordSpill (SpillJoinRR vreg)
 
 makeMove _     vreg (InReg src) (InReg dst)
  = do  recordSpill (SpillJoinRR vreg)

diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index ba8cdce..b91c2d0 100644 (file)
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -95,6 +95,9 @@ import RegAlloc.Linear.StackMap
 import RegAlloc.Linear.FreeRegs
 import RegAlloc.Linear.Stats
 import RegAlloc.Linear.JoinToTargets
 import RegAlloc.Linear.FreeRegs
 import RegAlloc.Linear.Stats
 import RegAlloc.Linear.JoinToTargets

+import qualified RegAlloc.Linear.PPC.FreeRegs   as PPC
+import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC
+import qualified RegAlloc.Linear.X86.FreeRegs   as X86

 import TargetReg
 import RegAlloc.Liveness
 import Instruction
 import TargetReg
 import RegAlloc.Liveness
 import Instruction

@@ -104,11 +107,13 @@ import BlockId
 import OldCmm hiding (RegSet)
 
 import Digraph
 import OldCmm hiding (RegSet)
 
 import Digraph

+import DynFlags

 import Unique
 import UniqSet
 import UniqFM
 import UniqSupply
 import Outputable
 import Unique
 import UniqSet
 import UniqFM
 import UniqSupply
 import Outputable

+import Platform

 
 import Data.Maybe
 import Data.List
 
 import Data.Maybe
 import Data.List

@@ -123,24 +128,25 @@ import Control.Monad
 -- Allocate registers
 regAlloc
         :: (Outputable instr, Instruction instr)
 -- Allocate registers
 regAlloc
         :: (Outputable instr, Instruction instr)

-        => LiveCmmTop instr
+        => DynFlags
+        -> LiveCmmTop instr

         -> UniqSM (NatCmmTop instr, Maybe RegAllocStats)
 
         -> UniqSM (NatCmmTop instr, Maybe RegAllocStats)
 

-regAlloc (CmmData sec d)
+regAlloc _ (CmmData sec d)

         = return
                 ( CmmData sec d
                 , Nothing )
 
         = return
                 ( CmmData sec d
                 , Nothing )
 

-regAlloc (CmmProc (LiveInfo info _ _ _) lbl [])
+regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl [])

         = return ( CmmProc info lbl (ListGraph [])
                  , Nothing )
 
         = return ( CmmProc info lbl (ListGraph [])
                  , Nothing )
 

-regAlloc (CmmProc static lbl sccs)
+regAlloc dflags (CmmProc static lbl sccs)

         | LiveInfo info (Just first_id) (Just block_live) _     <- static
         = do
                 -- do register allocation on each component.
                 (final_blocks, stats)
         | LiveInfo info (Just first_id) (Just block_live) _     <- static
         = do
                 -- do register allocation on each component.
                 (final_blocks, stats)

-                        <- linearRegAlloc first_id block_live sccs
+                        <- linearRegAlloc dflags first_id block_live sccs

 
                 -- make sure the block that was first in the input list
                 --      stays at the front of the output
 
                 -- make sure the block that was first in the input list
                 --      stays at the front of the output

@@ -151,7 +157,7 @@ regAlloc (CmmProc static lbl sccs)
                         , Just stats)
 
 -- bogus. to make non-exhaustive match warning go away.
                         , Just stats)
 
 -- bogus. to make non-exhaustive match warning go away.

-regAlloc (CmmProc _ _ _)
+regAlloc _ (CmmProc _ _ _)

         = panic "RegAllocLinear.regAlloc: no match"
 
 
         = panic "RegAllocLinear.regAlloc: no match"
 
 

@@ -165,25 +171,43 @@ regAlloc (CmmProc _ _ _)
 --
 linearRegAlloc
         :: (Outputable instr, Instruction instr)
 --
 linearRegAlloc
         :: (Outputable instr, Instruction instr)

-        => BlockId                      -- ^ the first block
+        => DynFlags
+        -> BlockId                      -- ^ the first block

         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
         -> UniqSM ([NatBasicBlock instr], RegAllocStats)
 
         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
         -> UniqSM ([NatBasicBlock instr], RegAllocStats)
 

-linearRegAlloc first_id block_live sccs
+linearRegAlloc dflags first_id block_live sccs
+ = case platformArch $ targetPlatform dflags of
+   ArchX86     -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs)   first_id block_live sccs
+   ArchX86_64  -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs)   first_id block_live sccs
+   ArchSPARC   -> linearRegAlloc' (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs
+   ArchPPC     -> linearRegAlloc' (frInitFreeRegs :: PPC.FreeRegs)   first_id block_live sccs
+   ArchPPC_64  -> panic "linearRegAlloc ArchPPC_64"
+   ArchUnknown -> panic "linearRegAlloc ArchUnknown"
+
+linearRegAlloc'
+        :: (FR freeRegs, Outputable instr, Instruction instr)
+        => freeRegs
+        -> BlockId                      -- ^ the first block
+        -> BlockMap RegSet              -- ^ live regs on entry to each basic block
+        -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
+        -> UniqSM ([NatBasicBlock instr], RegAllocStats)
+
+linearRegAlloc' initFreeRegs first_id block_live sccs

  = do   us      <- getUs
         let (_, _, stats, blocks) =
                 runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
  = do   us      <- getUs
         let (_, _, stats, blocks) =
                 runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us

-                        $ linearRA_SCCs first_id block_live [] sccs
-
+                    $ linearRA_SCCs first_id block_live [] sccs

         return  (blocks, stats)
 
         return  (blocks, stats)
 

-linearRA_SCCs :: (Instruction instr, Outputable instr)
+
+linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)

               => BlockId
               -> BlockMap RegSet
               -> [NatBasicBlock instr]
               -> [SCC (LiveBasicBlock instr)]
               => BlockId
               -> BlockMap RegSet
               -> [NatBasicBlock instr]
               -> [SCC (LiveBasicBlock instr)]

-              -> RegM FreeRegs [NatBasicBlock instr]
+              -> RegM freeRegs [NatBasicBlock instr]

 
 linearRA_SCCs _ _ blocksAcc []
         = return $ reverse blocksAcc
 
 linearRA_SCCs _ _ blocksAcc []
         = return $ reverse blocksAcc

@@ -213,14 +237,14 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
    more sanity checking to guard against this eventuality.
 -}
 
    more sanity checking to guard against this eventuality.
 -}
 

-process :: (Instruction instr, Outputable instr)
+process :: (FR freeRegs, Instruction instr, Outputable instr)

         => BlockId
         -> BlockMap RegSet
         -> [GenBasicBlock (LiveInstr instr)]
         -> [GenBasicBlock (LiveInstr instr)]
         -> [[NatBasicBlock instr]]
         -> Bool
         => BlockId
         -> BlockMap RegSet
         -> [GenBasicBlock (LiveInstr instr)]
         -> [GenBasicBlock (LiveInstr instr)]
         -> [[NatBasicBlock instr]]
         -> Bool

-        -> RegM FreeRegs [[NatBasicBlock instr]]
+        -> RegM freeRegs [[NatBasicBlock instr]]

 
 process _ _ [] []         accum _
         = return $ reverse accum
 
 process _ _ [] []         accum _
         = return $ reverse accum

@@ -257,10 +281,10 @@ process first_id block_live (b@(BasicBlock id _) : blocks)
 -- | Do register allocation on this basic block
 --
 processBlock
 -- | Do register allocation on this basic block
 --
 processBlock

-        :: (Outputable instr, Instruction instr)
+        :: (FR freeRegs, Outputable instr, Instruction instr)

         => BlockMap RegSet              -- ^ live regs on entry to each basic block
         -> LiveBasicBlock instr         -- ^ block to do register allocation on
         => 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
+        -> RegM freeRegs [NatBasicBlock instr]   -- ^ block with registers allocated

 
 processBlock block_live (BasicBlock id instrs)
  = do   initBlock id
 
 processBlock block_live (BasicBlock id instrs)
  = do   initBlock id

@@ -271,7 +295,7 @@ processBlock block_live (BasicBlock id instrs)
 
 -- | Load the freeregs and current reg assignment into the RegM state
 --      for the basic block with this BlockId.
 
 -- | Load the freeregs and current reg assignment into the RegM state
 --      for the basic block with this BlockId.

-initBlock :: BlockId -> RegM FreeRegs ()
+initBlock :: FR freeRegs => BlockId -> RegM freeRegs ()

 initBlock id
  = do   block_assig     <- getBlockAssigR
         case mapLookup id block_assig of
 initBlock id
  = do   block_assig     <- getBlockAssigR
         case mapLookup id block_assig of

@@ -280,7 +304,7 @@ initBlock id
                 Nothing
                  -> do  -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
 
                 Nothing
                  -> do  -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
 

-                        setFreeRegsR    initFreeRegs
+                        setFreeRegsR    frInitFreeRegs

                         setAssigR       emptyRegMap
 
                 -- load info about register assignments leading into this block.
                         setAssigR       emptyRegMap
 
                 -- load info about register assignments leading into this block.

@@ -291,14 +315,14 @@ initBlock id
 
 -- | Do allocation for a sequence of instructions.
 linearRA
 
 -- | Do allocation for a sequence of instructions.
 linearRA

-        :: (Outputable instr, Instruction instr)
+        :: (FR freeRegs, Outputable instr, Instruction instr)

         => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.
         -> [instr]                              -- ^ accumulator for instructions already processed.
         -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.
         -> BlockId                              -- ^ id of the current block, for debugging.
         -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
 
         => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.
         -> [instr]                              -- ^ accumulator for instructions already processed.
         -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.
         -> BlockId                              -- ^ id of the current block, for debugging.
         -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
 

-        -> RegM FreeRegs
+        -> RegM freeRegs

                 ( [instr]                       --   instructions after register allocation
                 , [NatBasicBlock instr])        --   fresh blocks of fixup code.
 
                 ( [instr]                       --   instructions after register allocation
                 , [NatBasicBlock instr])        --   fresh blocks of fixup code.
 

@@ -319,12 +343,12 @@ linearRA block_live accInstr accFixups id (instr:instrs)
 
 -- | Do allocation for a single instruction.
 raInsn
 
 -- | Do allocation for a single instruction.
 raInsn

-        :: (Outputable instr, Instruction instr)
+        :: (FR freeRegs, Outputable instr, Instruction instr)

         => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.
         -> [instr]                              -- ^ accumulator for instructions already processed.
         -> BlockId                              -- ^ the id of the current block, for debugging
         -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.
         => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.
         -> [instr]                              -- ^ accumulator for instructions already processed.
         -> BlockId                              -- ^ the id of the current block, for debugging
         -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.

-        -> RegM FreeRegs
+        -> RegM freeRegs

                 ( [instr]                       -- new instructions
                 , [NatBasicBlock instr])        -- extra fixup blocks
 
                 ( [instr]                       -- new instructions
                 , [NatBasicBlock instr])        -- extra fixup blocks
 

@@ -382,14 +406,14 @@ raInsn _ _ _ instr
         = pprPanic "raInsn" (text "no match for:" <> ppr instr)
 
 
         = pprPanic "raInsn" (text "no match for:" <> ppr instr)
 
 

-genRaInsn :: (Instruction instr, Outputable instr)
+genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr)

           => BlockMap RegSet
           -> [instr]
           -> BlockId
           -> instr
           -> [Reg]
           -> [Reg]
           => BlockMap RegSet
           -> [instr]
           -> BlockId
           -> instr
           -> [Reg]
           -> [Reg]

-          -> RegM FreeRegs ([instr], [NatBasicBlock instr])
+          -> RegM freeRegs ([instr], [NatBasicBlock instr])

 
 genRaInsn block_live new_instrs block_id instr r_dying w_dying =
     case regUsageOfInstr instr              of { RU read written ->
 
 genRaInsn block_live new_instrs block_id instr r_dying w_dying =
     case regUsageOfInstr instr              of { RU read written ->

@@ -486,7 +510,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying =
 -- -----------------------------------------------------------------------------
 -- releaseRegs
 
 -- -----------------------------------------------------------------------------
 -- releaseRegs
 

-releaseRegs :: [Reg] -> RegM FreeRegs ()
+releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()

 releaseRegs regs = do
   assig <- getAssigR
   free <- getFreeRegsR
 releaseRegs regs = do
   assig <- getAssigR
   free <- getFreeRegsR

@@ -494,11 +518,11 @@ releaseRegs regs = do
  where
   loop _     free _ | free `seq` False = undefined
   loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
  where
   loop _     free _ | free `seq` False = undefined
   loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()

-  loop assig free (RegReal rr : rs) = loop assig (releaseReg rr free) rs
+  loop assig free (RegReal rr : rs) = loop assig (frReleaseReg rr free) rs

   loop assig free (r:rs) =
      case lookupUFM assig r of
   loop assig free (r:rs) =
      case lookupUFM assig r of

-        Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
-        Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
+        Just (InBoth real _) -> loop (delFromUFM assig r) (frReleaseReg real free) rs
+        Just (InReg real) -> loop (delFromUFM assig r) (frReleaseReg real free) rs

         _other            -> loop (delFromUFM assig r) free rs
 
 
         _other            -> loop (delFromUFM assig r) free rs
 
 

@@ -524,7 +548,7 @@ saveClobberedTemps
         :: (Outputable instr, Instruction instr)
         => [RealReg]            -- real registers clobbered by this instruction
         -> [Reg]                -- registers which are no longer live after this insn
         :: (Outputable instr, Instruction instr)
         => [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
+        -> RegM freeRegs [instr]         -- return: instructions to spill any temps that will

                                 -- be clobbered.
 
 saveClobberedTemps [] _
                                 -- be clobbered.
 
 saveClobberedTemps [] _

@@ -563,14 +587,14 @@ saveClobberedTemps clobbered dying
 -- | Mark all these real regs as allocated,
 --      and kick out their vreg assignments.
 --
 -- | Mark all these real regs as allocated,
 --      and kick out their vreg assignments.
 --

-clobberRegs :: [RealReg] -> RegM FreeRegs ()
+clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()

 clobberRegs []
         = return ()
 
 clobberRegs clobbered
  = do
         freeregs        <- getFreeRegsR
 clobberRegs []
         = return ()
 
 clobberRegs clobbered
  = do
         freeregs        <- getFreeRegsR

-        setFreeRegsR $! foldr allocateReg freeregs clobbered
+        setFreeRegsR $! foldr frAllocateReg freeregs clobbered

 
         assig           <- getAssigR
         setAssigR $! clobber assig (ufmToList assig)
 
         assig           <- getAssigR
         setAssigR $! clobber assig (ufmToList assig)

@@ -613,13 +637,13 @@ data SpillLoc = ReadMem StackSlot  -- reading from register only in memory
 --   the list of free registers and free stack slots.
 
 allocateRegsAndSpill
 --   the list of free registers and free stack slots.
 
 allocateRegsAndSpill

-        :: (Outputable instr, Instruction instr)
+        :: (FR freeRegs, Outputable instr, Instruction instr)

         => Bool                 -- True <=> reading (load up spilled regs)
         -> [VirtualReg]         -- don't push these out
         -> [instr]              -- spill insns
         -> [RealReg]            -- real registers allocated (accum.)
         -> [VirtualReg]         -- temps to allocate
         => 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])
+        -> RegM freeRegs ( [instr] , [RealReg])

 
 allocateRegsAndSpill _       _    spills alloc []
         = return (spills, reverse alloc)
 
 allocateRegsAndSpill _       _    spills alloc []
         = return (spills, reverse alloc)

@@ -657,7 +681,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs)
 
 -- reading is redundant with reason, but we keep it around because it's
 -- convenient and it maintains the recursive structure of the allocator. -- EZY
 
 -- 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 :: (Instruction instr, Outputable instr)
+allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)

                         => Bool
                         -> [VirtualReg]
                         -> [instr]
                         => Bool
                         -> [VirtualReg]
                         -> [instr]

@@ -666,11 +690,11 @@ allocRegsAndSpill_spill :: (Instruction instr, Outputable instr)
                         -> [VirtualReg]
                         -> UniqFM Loc
                         -> SpillLoc
                         -> [VirtualReg]
                         -> UniqFM Loc
                         -> SpillLoc

-                        -> RegM FreeRegs ([instr], [RealReg])
+                        -> RegM freeRegs ([instr], [RealReg])

 allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
  = do
         freeRegs                <- getFreeRegsR
 allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
  = do
         freeRegs                <- getFreeRegsR

-        let freeRegs_thisClass  = getFreeRegs (classOfVirtualReg r) freeRegs
+        let freeRegs_thisClass  = frGetFreeRegs (classOfVirtualReg r) freeRegs

 
         case freeRegs_thisClass of
 
 
         case freeRegs_thisClass of
 

@@ -679,7 +703,7 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
            do   spills'   <- loadTemp r spill_loc my_reg spills
 
                 setAssigR       (addToUFM assig r $! newLocation spill_loc my_reg)
            do   spills'   <- loadTemp r spill_loc my_reg spills
 
                 setAssigR       (addToUFM assig r $! newLocation spill_loc my_reg)

-                setFreeRegsR $  allocateReg my_reg freeRegs
+                setFreeRegsR $  frAllocateReg my_reg freeRegs

 
                 allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
 
 
                 allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
 

@@ -748,7 +772,7 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
                                 [ text "allocating vreg:  " <> text (show r)
                                 , text "assignment:       " <> text (show $ ufmToList assig)
                                 , text "freeRegs:         " <> text (show freeRegs)
                                 [ text "allocating vreg:  " <> text (show r)
                                 , text "assignment:       " <> text (show $ ufmToList assig)
                                 , text "freeRegs:         " <> text (show freeRegs)

-                                , text "initFreeRegs:     " <> text (show initFreeRegs) ]
+                                , text "initFreeRegs:     " <> text (show (frInitFreeRegs `asTypeOf` freeRegs)) ]

 
                 result
 
 
                 result
 

@@ -767,7 +791,7 @@ loadTemp
         -> SpillLoc     -- the current location of this temp
         -> RealReg      -- the hreg to load the temp into
         -> [instr]
         -> SpillLoc     -- the current location of this temp
         -> RealReg      -- the hreg to load the temp into
         -> [instr]

-        -> RegM FreeRegs [instr]
+        -> RegM freeRegs [instr]

 
 loadTemp vreg (ReadMem slot) hreg spills
  = do
 
 loadTemp vreg (ReadMem slot) hreg spills
  = do

diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs
index 7793fee..05db9de 100644 (file)
--- a/compiler/nativeGen/RegAlloc/Linear/State.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/State.hs
@@ -32,7 +32,6 @@ where
 import RegAlloc.Linear.Stats
 import RegAlloc.Linear.StackMap
 import RegAlloc.Linear.Base
 import RegAlloc.Linear.Stats
 import RegAlloc.Linear.StackMap
 import RegAlloc.Linear.Base

-import RegAlloc.Linear.FreeRegs

 import RegAlloc.Liveness
 import Instruction
 import Reg
 import RegAlloc.Liveness
 import Instruction
 import Reg

@@ -48,13 +47,13 @@ instance Monad (RegM freeRegs) where
 
 
 -- | Run a computation in the RegM register allocator monad.
 
 
 -- | Run a computation in the RegM register allocator monad.

-runR   :: BlockAssignment 
-       -> FreeRegs 
+runR   :: BlockAssignment freeRegs
+       -> freeRegs 

        -> RegMap Loc
        -> StackMap 
        -> UniqSupply
        -> RegMap Loc
        -> StackMap 
        -> UniqSupply

-       -> RegM FreeRegs a 
-       -> (BlockAssignment, StackMap, RegAllocStats, a)
+       -> RegM freeRegs a 
+       -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)

 
 runR block_assig freeregs assig stack us thing =
   case unReg thing 
 
 runR block_assig freeregs assig stack us thing =
   case unReg thing 

@@ -76,14 +75,14 @@ runR block_assig freeregs assig stack us thing =
 
 
 -- | Make register allocator stats from its final state.
 
 
 -- | Make register allocator stats from its final state.

-makeRAStats :: RA_State FreeRegs -> RegAllocStats
+makeRAStats :: RA_State freeRegs -> RegAllocStats

 makeRAStats state
        = RegAllocStats
        { ra_spillInstrs        = binSpillReasons (ra_spills state) }
 
 
 spillR         :: Instruction instr
 makeRAStats state
        = RegAllocStats
        { ra_spillInstrs        = binSpillReasons (ra_spills state) }
 
 
 spillR         :: Instruction instr

-       => Reg -> Unique -> RegM FreeRegs (instr, Int)
+       => Reg -> Unique -> RegM freeRegs (instr, Int)

 
 spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
   let (stack',slot) = getStackSlotFor stack temp
 
 spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
   let (stack',slot) = getStackSlotFor stack temp

@@ -93,49 +92,49 @@ spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
 
 
 loadR  :: Instruction instr
 
 
 loadR  :: Instruction instr

-       => Reg -> Int -> RegM FreeRegs instr
+       => Reg -> Int -> RegM freeRegs instr

 
 loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
   (# s, mkLoadInstr reg delta slot #)
 
 
 loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
   (# s, mkLoadInstr reg delta slot #)
 

-getFreeRegsR :: RegM FreeRegs FreeRegs
+getFreeRegsR :: RegM freeRegs freeRegs

 getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
   (# s, freeregs #)
 
 getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
   (# s, freeregs #)
 

-setFreeRegsR :: FreeRegs -> RegM FreeRegs ()
+setFreeRegsR :: freeRegs -> RegM freeRegs ()

 setFreeRegsR regs = RegM $ \ s ->
   (# s{ra_freeregs = regs}, () #)
 
 setFreeRegsR regs = RegM $ \ s ->
   (# s{ra_freeregs = regs}, () #)
 

-getAssigR :: RegM FreeRegs (RegMap Loc)
+getAssigR :: RegM freeRegs (RegMap Loc)

 getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
   (# s, assig #)
 
 getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
   (# s, assig #)
 

-setAssigR :: RegMap Loc -> RegM FreeRegs ()
+setAssigR :: RegMap Loc -> RegM freeRegs ()

 setAssigR assig = RegM $ \ s ->
   (# s{ra_assig=assig}, () #)
 
 setAssigR assig = RegM $ \ s ->
   (# s{ra_assig=assig}, () #)
 

-getBlockAssigR :: RegM FreeRegs BlockAssignment
+getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)

 getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
   (# s, assig #)
 
 getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
   (# s, assig #)
 

-setBlockAssigR :: BlockAssignment -> RegM FreeRegs ()
+setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()

 setBlockAssigR assig = RegM $ \ s ->
   (# s{ra_blockassig = assig}, () #)
 
 setBlockAssigR assig = RegM $ \ s ->
   (# s{ra_blockassig = assig}, () #)
 

-setDeltaR :: Int -> RegM FreeRegs ()
+setDeltaR :: Int -> RegM freeRegs ()

 setDeltaR n = RegM $ \ s ->
   (# s{ra_delta = n}, () #)
 
 setDeltaR n = RegM $ \ s ->
   (# s{ra_delta = n}, () #)
 

-getDeltaR :: RegM FreeRegs Int
+getDeltaR :: RegM freeRegs Int

 getDeltaR = RegM $ \s -> (# s, ra_delta s #)
 
 getDeltaR = RegM $ \s -> (# s, ra_delta s #)
 

-getUniqueR :: RegM FreeRegs Unique
+getUniqueR :: RegM freeRegs Unique

 getUniqueR = RegM $ \s ->
   case takeUniqFromSupply (ra_us s) of
     (uniq, us) -> (# s{ra_us = us}, uniq #)
 
 
 -- | Record that a spill instruction was inserted, for profiling.
 getUniqueR = RegM $ \s ->
   case takeUniqFromSupply (ra_us s) of
     (uniq, us) -> (# s{ra_us = us}, uniq #)
 
 
 -- | Record that a spill instruction was inserted, for profiling.

-recordSpill :: SpillReason -> RegM FreeRegs ()
+recordSpill :: SpillReason -> RegM freeRegs ()

 recordSpill spill
        = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
 recordSpill spill
        = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)