Add spill/reload pseudo instrs to MachInstrs

Spiller can now insert spill/reload instrs without having to
worry about the current stack delta. Generation of actual machine
instructions for spills/reloads is deferred until after register
allocation proper.

diff --git a/compiler/nativeGen/MachInstrs.hs b/compiler/nativeGen/MachInstrs.hs
index 5ed8c0c..0c5dbdd 100644 (file)
--- a/compiler/nativeGen/MachInstrs.hs
+++ b/compiler/nativeGen/MachInstrs.hs
@@ -226,6 +226,9 @@ data Instr
   | DELTA   Int                 -- specify current stack offset for
                                 -- benefit of subsequent passes
 
   | DELTA   Int                 -- specify current stack offset for
                                 -- benefit of subsequent passes
 

+  | SPILL   Reg Int            -- ^ spill this reg to a stack slot
+  | RELOAD  Int Reg            -- ^ reload this reg from a stack slot
+

 -- -----------------------------------------------------------------------------
 -- Alpha instructions
 
 -- -----------------------------------------------------------------------------
 -- Alpha instructions
 

diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs
index 6a72265..a2ae0e3 100644 (file)
--- a/compiler/nativeGen/PprMach.hs
+++ b/compiler/nativeGen/PprMach.hs
@@ -829,6 +829,22 @@ pprInstr (LDATA _ _)
 
 #if alpha_TARGET_ARCH
 
 
 #if alpha_TARGET_ARCH
 

+pprInstr (SPILL reg slot)
+   = hcat [
+       ptext SLIT("\tSPILL"),
+       char '\t',
+       pprReg reg,
+       comma,
+       ptext SLIT("SLOT") <> parens (int slot)]
+
+pprInstr (RELOAD slot reg)
+   = hcat [
+       ptext SLIT("\tRELOAD"),
+       char '\t',
+       ptext SLIT("SLOT") <> parens (int slot),
+       comma,
+       pprReg reg]
+

 pprInstr (LD size reg addr)
   = hcat [
        ptext SLIT("\tld"),
 pprInstr (LD size reg addr)
   = hcat [
        ptext SLIT("\tld"),

@@ -1222,6 +1238,22 @@ pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack                -- write a pass for t
 #endif
 -}
 
 #endif
 -}
 

+pprInstr (SPILL reg slot)
+   = hcat [
+       ptext SLIT("\tSPILL"),
+       char ' ',
+       pprUserReg reg,
+       comma,
+       ptext SLIT("SLOT") <> parens (int slot)]
+
+pprInstr (RELOAD slot reg)
+   = hcat [
+       ptext SLIT("\tRELOAD"),
+       char ' ',
+       ptext SLIT("SLOT") <> parens (int slot),
+       comma,
+       pprUserReg reg]
+

 pprInstr (MOV size src dst)
   = pprSizeOpOp SLIT("mov") size src dst
 
 pprInstr (MOV size src dst)
   = pprSizeOpOp SLIT("mov") size src dst
 

@@ -1783,6 +1815,22 @@ pprCondInstr name cond arg
 -- reads (bytearrays).
 --
 
 -- reads (bytearrays).
 --
 

+pprInstr (SPILL reg slot)
+   = hcat [
+       ptext SLIT("\tSPILL"),
+       char '\t',
+       pprReg reg,
+       comma,
+       ptext SLIT("SLOT") <> parens (int slot)]
+
+pprInstr (RELOAD slot reg)
+   = hcat [
+       ptext SLIT("\tRELOAD"),
+       char '\t',
+       ptext SLIT("SLOT") <> parens (int slot),
+       comma,
+       pprReg reg]
+

 -- Translate to the following:
 --    add g1,g2,g1
 --    ld  [g1],%fn
 -- Translate to the following:
 --    add g1,g2,g1
 --    ld  [g1],%fn

@@ -2057,6 +2105,23 @@ pp_comma_a         = text ",a"
 -- pprInstr for PowerPC
 
 #if powerpc_TARGET_ARCH
 -- pprInstr for PowerPC
 
 #if powerpc_TARGET_ARCH

+
+pprInstr (SPILL reg slot)
+   = hcat [
+       ptext SLIT("\tSPILL"),
+       char '\t',
+       pprReg reg,
+       comma,
+       ptext SLIT("SLOT") <> parens (int slot)]
+
+pprInstr (RELOAD slot reg)
+   = hcat [
+       ptext SLIT("\tRELOAD"),
+       char '\t',
+       ptext SLIT("SLOT") <> parens (int slot),
+       comma,
+       pprReg reg]
+

 pprInstr (LD sz reg addr) = hcat [
        char '\t',
        ptext SLIT("l"),
 pprInstr (LD sz reg addr) = hcat [
        char '\t',
        ptext SLIT("l"),

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 0a5c160..92efc4a 100644 (file)
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -105,8 +105,12 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
        if isEmptyUniqSet rsSpill
         then do
                -- patch the registers using the info in the graph
        if isEmptyUniqSet rsSpill
         then do
                -- patch the registers using the info in the graph

+               --      also rewrite SPILL/REALOAD pseudos into real instructions

                let code_patched        = map (patchRegsFromGraph graph_colored) code
                let code_patched        = map (patchRegsFromGraph graph_colored) code

-               let code_nat            = map stripLive code_patched
+
+               let spillNatTop         = mapGenBlockTop spillNatBlock
+               let code_nat            = map (spillNatTop . stripLive) code_patched
+

                
                -- record what happened in this stage for debugging
                let stat                =
                
                -- record what happened in this stage for debugging
                let stat                =

diff --git a/compiler/nativeGen/RegAllocInfo.hs b/compiler/nativeGen/RegAllocInfo.hs
index 4cb688a..9b60fb9 100644 (file)
--- a/compiler/nativeGen/RegAllocInfo.hs
+++ b/compiler/nativeGen/RegAllocInfo.hs
@@ -69,6 +69,8 @@ interesting (RealReg i)       = isFastTrue (freeReg i)
 
 #if alpha_TARGET_ARCH
 regUsage instr = case instr of
 
 #if alpha_TARGET_ARCH
 regUsage instr = case instr of

+    SPILL  reg slot    -> usage ([reg], [])
+    RELOAD slot reg    -> usage ([], [reg])

     LD B reg addr      -> usage (regAddr addr, [reg, t9])
     LD Bu reg addr     -> usage (regAddr addr, [reg, t9])
 --  LD W reg addr      -> usage (regAddr addr, [reg, t9]) : UNUSED
     LD B reg addr      -> usage (regAddr addr, [reg, t9])
     LD Bu reg addr     -> usage (regAddr addr, [reg, t9])
 --  LD W reg addr      -> usage (regAddr addr, [reg, t9]) : UNUSED

@@ -226,6 +228,8 @@ regUsage instr = case instr of
 
     COMMENT _          -> noUsage
     DELTA   _           -> noUsage
 
     COMMENT _          -> noUsage
     DELTA   _           -> noUsage

+    SPILL   reg slot   -> mkRU [reg] []
+    RELOAD  slot reg   -> mkRU []    [reg]

 
     _other             -> panic "regUsage: unrecognised instr"
 
 
     _other             -> panic "regUsage: unrecognised instr"
 

@@ -275,6 +279,9 @@ regUsage instr = case instr of
 #if sparc_TARGET_ARCH
 
 regUsage instr = case instr of
 #if sparc_TARGET_ARCH
 
 regUsage instr = case instr of

+    SPILL reg slot     -> usage ([reg], [])
+    RELOAD slot reg    -> usage ([], [reg])
+

     LD    sz addr reg          -> usage (regAddr addr, [reg])
     ST    sz reg addr          -> usage (reg : regAddr addr, [])
     ADD   x cc r1 ar r2        -> usage (r1 : regRI ar, [r2])
     LD    sz addr reg          -> usage (regAddr addr, [reg])
     ST    sz reg addr          -> usage (reg : regAddr addr, [])
     ADD   x cc r1 ar r2        -> usage (r1 : regRI ar, [r2])

@@ -327,6 +334,9 @@ regUsage instr = case instr of
 #if powerpc_TARGET_ARCH
 
 regUsage instr = case instr of
 #if powerpc_TARGET_ARCH
 
 regUsage instr = case instr of

+    SPILL  reg slot    -> usage ([reg], [])
+    RELOAD slot reg    -> usage ([], [reg])
+

     LD    sz reg addr          -> usage (regAddr addr, [reg])
     LA    sz reg addr          -> usage (regAddr addr, [reg])
     ST    sz reg addr          -> usage (reg : regAddr addr, [])
     LD    sz reg addr          -> usage (regAddr addr, [reg])
     LA    sz reg addr          -> usage (regAddr addr, [reg])
     ST    sz reg addr          -> usage (reg : regAddr addr, [])

@@ -471,6 +481,8 @@ patchRegs :: Instr -> (Reg -> Reg) -> Instr
 #if alpha_TARGET_ARCH
 
 patchRegs instr env = case instr of
 #if alpha_TARGET_ARCH
 
 patchRegs instr env = case instr of

+    SPILL  reg slot    -> SPILL (env reg) slot
+    RELOAD slot reg    -> RELOAD slot (env reg)

     LD sz reg addr -> LD sz (env reg) (fixAddr addr)
     LDA reg addr -> LDA (env reg) (fixAddr addr)
     LDAH reg addr -> LDAH (env reg) (fixAddr addr)
     LD sz reg addr -> LD sz (env reg) (fixAddr addr)
     LDA reg addr -> LDA (env reg) (fixAddr addr)
     LDAH reg addr -> LDAH (env reg) (fixAddr addr)

@@ -604,6 +616,9 @@ patchRegs instr env = case instr of
     NOP                        -> instr
     COMMENT _          -> instr
     DELTA _            -> instr
     NOP                        -> instr
     COMMENT _          -> instr
     DELTA _            -> instr

+    SPILL  reg slot    -> SPILL (env reg) slot
+    RELOAD slot reg    -> RELOAD slot (env reg)
+

     JXX _ _            -> instr
     JXX_GBL _ _                -> instr
     CLTD _             -> instr
     JXX _ _            -> instr
     JXX_GBL _ _                -> instr
     CLTD _             -> instr

@@ -634,6 +649,8 @@ patchRegs instr env = case instr of
 #if sparc_TARGET_ARCH
 
 patchRegs instr env = case instr of
 #if sparc_TARGET_ARCH
 
 patchRegs instr env = case instr of

+    SPILL reg slot     -> SPILL (env reg) slot
+    RELOAD slot reg    -> RELOAD slot (env reg)

     LD    sz addr reg   -> LD sz (fixAddr addr) (env reg)
     ST    sz reg addr   -> ST sz (env reg) (fixAddr addr)
     ADD   x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2)
     LD    sz addr reg   -> LD sz (fixAddr addr) (env reg)
     ST    sz reg addr   -> ST sz (env reg) (fixAddr addr)
     ADD   x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2)

@@ -677,6 +694,9 @@ patchRegs instr env = case instr of
 #if powerpc_TARGET_ARCH
 
 patchRegs instr env = case instr of
 #if powerpc_TARGET_ARCH
 
 patchRegs instr env = case instr of

+    SPILL reg slot     -> SPILL (env reg) slot
+    RELOAD slot reg    -> RELOAD slot (env reg)
+

     LD    sz reg addr   -> LD sz (env reg) (fixAddr addr)
     LA    sz reg addr   -> LA sz (env reg) (fixAddr addr)
     ST    sz reg addr   -> ST sz (env reg) (fixAddr addr)
     LD    sz reg addr   -> LD sz (env reg) (fixAddr addr)
     LA    sz reg addr   -> LA sz (env reg) (fixAddr addr)
     ST    sz reg addr   -> ST sz (env reg) (fixAddr addr)

diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 4acb3be..8f313ae 100644 (file)
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -17,15 +17,17 @@ module RegLiveness (
        LiveInfo (..),
        LiveBasicBlock,
 
        LiveInfo (..),
        LiveBasicBlock,
 

-       mapBlockTop,
-       mapBlockTopM,
+       mapBlockTop,    mapBlockTopM,
+       mapGenBlockTop, mapGenBlockTopM,

        stripLive,
        stripLive,

+       spillNatBlock,

        slurpConflicts,
        lifetimeCount,
        eraseDeltasLive,
        patchEraseLive,
        patchRegsLiveInstr,
        regLiveness
        slurpConflicts,
        lifetimeCount,
        eraseDeltasLive,
        patchEraseLive,
        patchRegsLiveInstr,
        regLiveness

+

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

@@ -153,6 +155,32 @@ mapBlockCompM f (BasicBlock i blocks)
        return  $ BasicBlock i blocks'
 
 
        return  $ BasicBlock i blocks'
 
 

+-- map a function across all the basic blocks in this code
+mapGenBlockTop
+       :: (GenBasicBlock i -> GenBasicBlock i)
+       -> (GenCmmTop d h i -> GenCmmTop d h i)
+
+mapGenBlockTop f cmm
+       = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
+
+
+-- | map a function across all the basic blocks in this code (monadic version)
+mapGenBlockTopM
+       :: Monad m
+       => (GenBasicBlock i -> m (GenBasicBlock i))
+       -> (GenCmmTop d h i -> m (GenCmmTop d h i))
+
+mapGenBlockTopM f cmm@(CmmData{})
+       = return cmm
+
+mapGenBlockTopM f (CmmProc header label params blocks)
+ = do  blocks' <- mapM f blocks
+       return  $ CmmProc header label params blocks'
+
+
+
+
+

 -- | Slurp out the list of register conflicts from this top level thing.
 
 slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
 -- | Slurp out the list of register conflicts from this top level thing.
 
 slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)

@@ -214,6 +242,30 @@ stripLive live
        stripLI    (Instr instr _)              = instr
 
 
        stripLI    (Instr instr _)              = instr
 
 

+-- | Make real spill instructions out of SPILL, RELOAD pseudos
+
+spillNatBlock :: NatBasicBlock -> NatBasicBlock
+spillNatBlock (BasicBlock i instrs)
+ =     BasicBlock i instrs'
+ where         (instrs', _)
+               = runState (mapM spillNat instrs) 0
+
+       spillNat instr@(DELTA i)
+        = do   put i
+               return instr
+
+       spillNat (SPILL reg slot)
+        = do   delta   <- get
+               return  $ mkSpillInstr reg delta slot
+
+       spillNat (RELOAD slot reg)
+        = do   delta   <- get
+               return  $ mkLoadInstr reg delta slot
+
+       spillNat instr
+        =      return instr
+
+

 -- | Slurp out a map of how many times each register was live upon entry to an instruction.
 
 lifetimeCount
 -- | Slurp out a map of how many times each register was live upon entry to an instruction.
 
 lifetimeCount

diff --git a/compiler/nativeGen/RegSpill.hs b/compiler/nativeGen/RegSpill.hs
index a349a56..873e779 100644 (file)
--- a/compiler/nativeGen/RegSpill.hs
+++ b/compiler/nativeGen/RegSpill.hs
@@ -75,16 +75,9 @@ regSpill_block regSlotMap (BasicBlock i instrs)
  = do  instrss'        <- mapM (regSpill_instr regSlotMap) instrs
        return  $ BasicBlock i (concat instrss')
 
  = do  instrss'        <- mapM (regSpill_instr regSlotMap) instrs
        return  $ BasicBlock i (concat instrss')
 

-
-regSpill_instr _       li@(Instr (DELTA delta) _)
- = do
-       setDelta delta
-       return [li]
-

 regSpill_instr _       li@(Instr _ Nothing)
  = do  return [li]
 
 regSpill_instr _       li@(Instr _ Nothing)
  = do  return [li]
 

-

 regSpill_instr regSlotMap
        (Instr instr (Just live))
  = do
 regSpill_instr regSlotMap
        (Instr instr (Just live))
  = do

@@ -135,49 +128,40 @@ regSpill_instr regSlotMap
 
 spillRead regSlotMap instr reg
        | Just slot     <- lookupUFM regSlotMap reg
 
 spillRead regSlotMap instr reg
        | Just slot     <- lookupUFM regSlotMap reg

-       = do    delta           <- getDelta
-               (instr', nReg)  <- patchInstr reg instr
-
-               let pre         = [ COMMENT FSLIT("spill load")
-                                 , mkLoadInstr nReg delta slot ]
+       = do    (instr', nReg)  <- patchInstr reg instr

 
                modify $ \s -> s
                        { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
 
 
                modify $ \s -> s
                        { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
 

-               return  ( instr', (pre, []))
+               return  ( instr'
+                       , ( [RELOAD slot nReg]
+                         , []) )

 
        | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"
 
 spillWrite regSlotMap instr reg
        | Just slot     <- lookupUFM regSlotMap reg
 
        | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"
 
 spillWrite regSlotMap instr reg
        | Just slot     <- lookupUFM regSlotMap reg

-       = do    delta           <- getDelta
-               (instr', nReg)  <- patchInstr reg instr
-
-               let post        = [ COMMENT FSLIT("spill store")
-                                 , mkSpillInstr nReg delta slot ]
+       = do    (instr', nReg)  <- patchInstr reg instr

 
                modify $ \s -> s
                        { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
 
 
                modify $ \s -> s
                        { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
 

-               return  ( instr', ([], post))
+               return  ( instr'
+                       , ( []
+                         , [SPILL nReg slot]))

 
        | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"
 
 spillModify regSlotMap instr reg
        | Just slot     <- lookupUFM regSlotMap reg
 
        | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"
 
 spillModify regSlotMap instr reg
        | Just slot     <- lookupUFM regSlotMap reg

-       = do    delta           <- getDelta
-               (instr', nReg)  <- patchInstr reg instr
-
-               let pre         = [ COMMENT FSLIT("spill mod load")
-                                 , mkLoadInstr  nReg delta slot ]
-
-               let post        = [ COMMENT FSLIT("spill mod store")
-                                 , mkSpillInstr nReg delta slot ]
+       = do    (instr', nReg)  <- patchInstr reg instr

 
                modify $ \s -> s
                        { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
 
 
                modify $ \s -> s
                        { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
 

-               return  ( instr', (pre, post))
+               return  ( instr'
+                       , ( [RELOAD slot nReg]
+                         , [SPILL nReg slot]))

 
        | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"
 
 
        | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"
 

@@ -204,25 +188,16 @@ patchReg1 old new instr
 
 data SpillS
        = SpillS
 
 data SpillS
        = SpillS

-       { stateDelta    :: Int
-       , stateUS       :: UniqSupply
+       { stateUS       :: UniqSupply

        , stateSpillSL  :: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
 
 initSpillS uniqueSupply
        = SpillS
        , stateSpillSL  :: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
 
 initSpillS uniqueSupply
        = SpillS

-       { stateDelta    = 0
-       , stateUS       = uniqueSupply
+       { stateUS       = uniqueSupply

        , stateSpillSL  = emptyUFM }
 
 type SpillM a  = State SpillS a
 
        , stateSpillSL  = emptyUFM }
 
 type SpillM a  = State SpillS a
 

-setDelta :: Int -> SpillM ()
-setDelta delta
-       = modify $ \s -> s { stateDelta = delta }
-
-getDelta  :: SpillM Int
-getDelta = gets stateDelta
-

 newUnique :: SpillM Unique
 newUnique
  = do  us      <- gets stateUS
 newUnique :: SpillM Unique
 newUnique
  = do  us      <- gets stateUS

@@ -236,7 +211,6 @@ accSpillSL (r1, s1, l1) (r2, s2, l2)
        = (r1, s1 + s2, l1 + l2)
 
 
        = (r1, s1 + s2, l1 + l2)
 
 

-

 ----------------------------------------------------
 -- Spiller stats
 
 ----------------------------------------------------
 -- Spiller stats