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

[ghc-hetmet.git] / compiler / nativeGen / RegAlloc / Linear / JoinToTargets.hs

diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index 8ff06eb..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.
 
@@ -23,7 +21,7 @@ import Instruction
 import Reg
 
 import BlockId
-import Cmm     hiding (RegSet)
+import OldCmm  hiding (RegSet)
 import Digraph
 import Outputable
 import Unique
@@ -35,14 +33,14 @@ import UniqSet
 --     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.
 
-       -> RegM ([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.
 
@@ -57,7 +55,7 @@ joinToTargets block_live id instr
 
 -----
 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.
 
@@ -68,7 +66,7 @@ joinToTargets'
 
        -> [BlockId]                    -- ^ branch destinations still to consider.
 
-       -> RegM ( [NatBasicBlock instr]
+       -> RegM freeRegs ( [NatBasicBlock instr]
                , instr)
 
 -- no more targets to consider. all done.
@@ -86,7 +84,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests)
 
        -- adjust the current assignment to remove any vregs that are not live
        -- on entry to the destination block.
-       let Just live_set       = lookupBlockEnv block_live dest
+       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
 
@@ -96,7 +94,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests)
                        , not (elemUniqSet_Directly reg live_set)
                        , r          <- regsOfLoc loc ]
 
-       case lookupBlockEnv block_assig dest of
+       case mapLookup dest block_assig of
         Nothing 
          -> joinToTargets_first 
                        block_live new_blocks block_id instr dest dests
@@ -109,22 +107,42 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests)
 
 
 -- 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 
-       (to_free :: [RealReg])
+       to_free
 
  = 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 (extendBlockEnv block_assig dest 
-                               (freeregs', src_assig))
+       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)
+                    => 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
@@ -173,7 +191,7 @@ joinToTargets_again
                --      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 (BlockId fixup_block_id) 
+               let block = BasicBlock (mkBlockId fixup_block_id) 
                                $ fixUpInstrs ++ mkJumpInstr dest
                
 {-             pprTrace
@@ -190,8 +208,8 @@ joinToTargets_again
                 --     fixup block instead.
                 _      -> let  instr'  =  patchJumpInstr instr 
                                                (\bid -> if bid == dest 
-                                                               then BlockId fixup_block_id 
-                                                               else dest)
+                                                               then mkBlockId fixup_block_id 
+                                                               else bid) -- no change!
                                                
                           in   joinToTargets' block_live (block : new_blocks) block_id instr' dests
 
@@ -263,7 +281,7 @@ expandNode vreg src dst
 --
 handleComponent 
        :: Instruction instr
-       => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM [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
@@ -289,7 +307,8 @@ handleComponent delta _  (AcyclicSCC (vreg, src, dsts))
 --     require a fixup.
 --
 handleComponent delta instr 
-       (CyclicSCC      ( (vreg, InReg sreg, [InReg dreg]) : rest))
+       (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) 
@@ -317,7 +336,7 @@ makeMove
        -> Unique       -- ^ unique of the vreg that we're moving.
        -> Loc          -- ^ source location.
        -> Loc          -- ^ destination location.
-       -> RegM instr   -- ^ move instruction.
+       -> RegM freeRegs instr  -- ^ move instruction.
 
 makeMove _     vreg (InReg src) (InReg dst)
  = do  recordSpill (SpillJoinRR vreg)