Replacing copyins and copyouts with data-movement instructions

o Moved BlockId stuff to a new file to avoid module recursion
o Defined stack areas for parameter-passing locations and spill slots
o Part way through replacing copy in and copy out nodes
  - added movement instructions for stack pointer
  - added movement instructions for call and return parameters
    (but not with the proper calling conventions)
o Inserting spills and reloads for proc points is now procpoint-aware
  (it was relying on the presence of a CopyIn node as a proxy for
   procpoint knowledge)
o Changed ZipDataflow to expect AGraphs (instead of being polymorphic in
   the type of graph)

diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs
new file mode 100644 (file)
index 0000000..fb9b7ca
--- /dev/null
+++ b/compiler/cmm/BlockId.hs
@@ -0,0 +1,60 @@
+module BlockId
+  ( BlockId(..), mkBlockId     -- ToDo: BlockId should be abstract, but it isn't yet
+  , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
+  , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, sizeBlockSet, mkBlockSet
+  ) where
+
+import Outputable
+import UniqFM
+import Unique
+import UniqSet
+
+----------------------------------------------------------------
+--- Block Ids, their environments, and their sets
+
+{- Note [Unique BlockId]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Although a 'BlockId' is a local label, for reasons of implementation,
+'BlockId's must be unique within an entire compilation unit.  The reason
+is that each local label is mapped to an assembly-language label, and in
+most assembly languages allow, a label is visible throughout the enitre
+compilation unit in which it appears.
+-}
+
+newtype BlockId = BlockId Unique
+  deriving (Eq,Ord)
+
+instance Uniquable BlockId where
+  getUnique (BlockId u) = u
+
+mkBlockId :: Unique -> BlockId
+mkBlockId uniq = BlockId uniq
+
+instance Show BlockId where
+  show (BlockId u) = show u
+
+instance Outputable BlockId where
+  ppr = ppr . getUnique
+
+
+type BlockEnv a = UniqFM {- BlockId -} a
+emptyBlockEnv :: BlockEnv a
+emptyBlockEnv = emptyUFM
+mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
+mkBlockEnv = listToUFM
+lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
+lookupBlockEnv = lookupUFM
+extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
+extendBlockEnv = addToUFM
+
+type BlockSet = UniqSet BlockId
+emptyBlockSet :: BlockSet
+emptyBlockSet = emptyUniqSet
+elemBlockSet :: BlockId -> BlockSet -> Bool
+elemBlockSet = elementOfUniqSet
+extendBlockSet :: BlockSet -> BlockId -> BlockSet
+extendBlockSet = addOneToUniqSet
+mkBlockSet :: [BlockId] -> BlockSet
+mkBlockSet = mkUniqSet
+sizeBlockSet :: BlockSet -> Int
+sizeBlockSet = sizeUniqSet

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 2d13c45..38dc5b3 100644 (file)
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -23,14 +23,11 @@ module Cmm (
        CmmCallTarget(..),
        CmmStatic(..), Section(..),
         module CmmExpr,
        CmmCallTarget(..),
        CmmStatic(..), Section(..),
         module CmmExpr,

-
-        BlockId(..), mkBlockId,
-        BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv,
-        BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet,

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

+import BlockId

 import CmmExpr
 import MachOp
 import CLabel
 import CmmExpr
 import MachOp
 import CLabel

@@ -42,10 +39,6 @@ import FastString
 
 import Data.Word
 
 
 import Data.Word
 

-import StackSlot (     BlockId(..), mkBlockId
-                 , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
-                 , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet
-                 )

 
 -- A [[BlockId]] is a local label.
 -- Local labels must be unique within an entire compilation unit, not
 
 -- A [[BlockId]] is a local label.
 -- Local labels must be unique within an entire compilation unit, not

@@ -277,7 +270,6 @@ instance UserOfLocalRegs CmmCallTarget where
 instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmKinded a) where
   foldRegsDefd f z (CmmKinded x _) = foldRegsDefd f z x
 
 instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmKinded a) where
   foldRegsDefd f z (CmmKinded x _) = foldRegsDefd f z x
 

-

 --just look like a tuple, since it was a tuple before
 -- ... is that a good idea? --Isaac Dupree
 instance (Outputable a) => Outputable (CmmKinded a) where
 --just look like a tuple, since it was a tuple before
 -- ... is that a good idea? --Isaac Dupree
 instance (Outputable a) => Outputable (CmmKinded a) where

diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs
index 526bdc1..6ffe3d7 100644 (file)
--- a/compiler/cmm/CmmBrokenBlock.hs
+++ b/compiler/cmm/CmmBrokenBlock.hs
@@ -20,6 +20,7 @@ module CmmBrokenBlock (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import BlockId

 import Cmm
 import CmmUtils
 import CLabel
 import Cmm
 import CmmUtils
 import CLabel

diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index a8adfb8..025c127 100644 (file)
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -13,6 +13,7 @@ module CmmCPS (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import BlockId

 import Cmm
 import CmmLint
 import PprCmm
 import Cmm
 import CmmLint
 import PprCmm

diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs
index d508184..dcbb0a5 100644 (file)
--- a/compiler/cmm/CmmCPSGen.hs
+++ b/compiler/cmm/CmmCPSGen.hs
@@ -13,6 +13,7 @@ module CmmCPSGen (
   ContinuationFormat(..),
 ) where
 
   ContinuationFormat(..),
 ) where
 

+import BlockId

 import Cmm
 import CLabel
 import CmmBrokenBlock -- Data types only
 import Cmm
 import CLabel
 import CmmBrokenBlock -- Data types only

diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index a09c8a6..b6b77f0 100644 (file)
--- a/compiler/cmm/CmmCPSZ.hs
+++ b/compiler/cmm/CmmCPSZ.hs
@@ -5,6 +5,7 @@ module CmmCPSZ (
   protoCmmCPSZ
 ) where
 
   protoCmmCPSZ
 ) where
 

+import BlockId

 import Cmm
 import CmmCommonBlockElimZ
 import CmmContFlowOpt
 import Cmm
 import CmmCommonBlockElimZ
 import CmmContFlowOpt

@@ -53,14 +54,13 @@ cpsTop _ p@(CmmData {}) = return p
 cpsTop hsc_env (CmmProc h l args g) =
     do dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
        let callPPs = callProcPoints g
 cpsTop hsc_env (CmmProc h l args g) =
     do dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
        let callPPs = callProcPoints g

-       procPoints <- run $ minimalProcPointSet callPPs (runTx cmmCfgOptsZ g)
-       let varSlots = emptyFM

        g <- return $ map_nodes id NotSpillOrReload id g
                -- Change types of middle nodes to allow spill/reload
        g     <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
        g <- return $ map_nodes id NotSpillOrReload id g
                -- Change types of middle nodes to allow spill/reload
        g     <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"

-                             (dualLivenessWithInsertion emptyBlockSet) g
-       (varSlots, g) <- trim g >>= run . elimSpillAndReload varSlots
-       g <- run $ addProcPointProtocols callPPs procPoints args g
+                             (dualLivenessWithInsertion callPPs) g
+       (varSlots, g) <- trim g >>= return . elimSpillAndReload emptyFM
+       procPoints <- run $ minimalProcPointSet callPPs (runTx cmmCfgOptsZ g)
+       g <- run $ addProcPointProtocols callPPs procPoints g

        dump Opt_D_dump_cmmz "Post Proc Points Added" g
        g <- return $ map_nodes id NotSpillOrReload id g
                -- Change types of middle nodes to allow spill/reload
        dump Opt_D_dump_cmmz "Post Proc Points Added" g
        g <- return $ map_nodes id NotSpillOrReload id g
                -- Change types of middle nodes to allow spill/reload

@@ -72,7 +72,7 @@ cpsTop hsc_env (CmmProc h l args g) =
        g     <- trim g >>= dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
                                         (removeDeadAssignmentsAndReloads procPoints)
                     -- Remove redundant reloads (and any other redundant asst)
        g     <- trim g >>= dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
                                         (removeDeadAssignmentsAndReloads procPoints)
                     -- Remove redundant reloads (and any other redundant asst)

-       (_, g) <- trim g >>= run . elimSpillAndReload varSlots
+       (_, g) <- trim g >>= return . elimSpillAndReload varSlots

        gs    <- run $ splitAtProcPoints args l procPoints g
        gs `seq` dump Opt_D_dump_cmmz "Pre common block elimination" g
        g     <- return $ elimCommonBlocks g
        gs    <- run $ splitAtProcPoints args l procPoints g
        gs `seq` dump Opt_D_dump_cmmz "Pre common block elimination" g
        g     <- return $ elimCommonBlocks g

diff --git a/compiler/cmm/CmmCommonBlockElimZ.hs b/compiler/cmm/CmmCommonBlockElimZ.hs
index 06e2831..97ec31d 100644 (file)
--- a/compiler/cmm/CmmCommonBlockElimZ.hs
+++ b/compiler/cmm/CmmCommonBlockElimZ.hs
@@ -4,6 +4,7 @@ module CmmCommonBlockElimZ
 where
 
 
 where
 
 

+import BlockId

 import Cmm hiding (blockId)
 import CmmExpr
 import Prelude hiding (iterate, zip, unzip)
 import Cmm hiding (blockId)
 import CmmExpr
 import Prelude hiding (iterate, zip, unzip)

@@ -89,13 +90,13 @@ hash_block (Block _ t) = hash_tail t 0
         hash_mid   (CopyOut _ as) = hash_as as
         hash_reg   (CmmLocal l) = hash_local l
         hash_reg   (CmmGlobal _)    = 19
         hash_mid   (CopyOut _ as) = hash_as as
         hash_reg   (CmmLocal l) = hash_local l
         hash_reg   (CmmGlobal _)    = 19

-        hash_reg   (CmmStack _)    = 13

         hash_local (LocalReg _ _ _) = 117
         hash_e (CmmLit l) = hash_lit l
         hash_e (CmmLoad e _) = 67 + hash_e e
         hash_e (CmmReg r) = hash_reg r
         hash_e (CmmMachOp _ es) = hash_lst hash_e es -- pessimal - no operator check
         hash_e (CmmRegOff r i) = hash_reg r + i
         hash_local (LocalReg _ _ _) = 117
         hash_e (CmmLit l) = hash_lit l
         hash_e (CmmLoad e _) = 67 + hash_e e
         hash_e (CmmReg r) = hash_reg r
         hash_e (CmmMachOp _ es) = hash_lst hash_e es -- pessimal - no operator check
         hash_e (CmmRegOff r i) = hash_reg r + i

+        hash_e (CmmStackSlot _ _) = 13

         hash_lit (CmmInt i _) = fromInteger i
         hash_lit (CmmFloat r _) = truncate r
         hash_lit (CmmLabel _) = 119 -- ugh
         hash_lit (CmmInt i _) = fromInteger i
         hash_lit (CmmFloat r _) = truncate r
         hash_lit (CmmLabel _) = 119 -- ugh

diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index 3ab4793..b9a14af 100644 (file)
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -6,10 +6,10 @@ module CmmContFlowOpt
     )
 where
 
     )
 where
 

+import BlockId

 import Cmm
 import CmmTx
 import qualified ZipCfg as G
 import Cmm
 import CmmTx
 import qualified ZipCfg as G

-import StackSlot

 import ZipCfgCmmRep
 
 import Maybes
 import ZipCfgCmmRep
 
 import Maybes

diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
index 3cbd328..0bfa396 100644 (file)
--- a/compiler/cmm/CmmCvt.hs
+++ b/compiler/cmm/CmmCvt.hs
@@ -4,6 +4,7 @@ module CmmCvt
   ( cmmToZgraph, cmmOfZgraph )
 where
 
   ( cmmToZgraph, cmmOfZgraph )
 where
 

+import BlockId

 import Cmm
 import CmmExpr
 import MkZipCfg
 import Cmm
 import CmmExpr
 import MkZipCfg

@@ -36,7 +37,7 @@ cmmOfZgraph = cmmMapGraph  ofZgraph
 toZgraph :: String -> CmmFormalsWithoutKinds -> ListGraph CmmStmt -> UniqSM CmmGraph
 toZgraph _ _ (ListGraph []) = lgraphOfAGraph emptyAGraph
 toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = 
 toZgraph :: String -> CmmFormalsWithoutKinds -> ListGraph CmmStmt -> UniqSM CmmGraph
 toZgraph _ _ (ListGraph []) = lgraphOfAGraph emptyAGraph
 toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = 

-           labelAGraph id $ mkMiddles (mkEntry id undefined args) <*>
+           labelAGraph id $ mkMiddles (mkEntry area undefined args) <*>

                             mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
   where addBlock (BasicBlock id ss) g = mkLabel id   <*> mkStmts ss <*> g
         mkStmts (CmmNop        : ss)  = mkNop        <*> mkStmts ss 
                             mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
   where addBlock (BasicBlock id ss) g = mkLabel id   <*> mkStmts ss <*> g
         mkStmts (CmmNop        : ss)  = mkNop        <*> mkStmts ss 

@@ -60,12 +61,28 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
         mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
             panic "Call to CmmPrim never returns?!"
         mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
         mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
             panic "Call to CmmPrim never returns?!"
         mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table

-        mkLast (CmmJump tgt args)          = mkJump tgt args
-        mkLast (CmmReturn ress)            = mkReturn ress
+        mkLast (CmmJump tgt args)          = mkJump   area tgt args
+        mkLast (CmmReturn ress)            = mkReturn area ress

         mkLast (CmmBranch tgt)             = mkBranch tgt
         mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
                    panic "Call never returns but has results?!"
         mkLast _ = panic "fell off end of block"
         mkLast (CmmBranch tgt)             = mkBranch tgt
         mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
                    panic "Call never returns but has results?!"
         mkLast _ = panic "fell off end of block"

+        -- The entry, jump, and return areas should be the same.
+        -- This code is horrible, but there's no point trying to fix it until we've figured
+        -- out our interface for calling conventions.
+        -- All return statements are required to use return areas of equal size.
+        -- This isn't necessarily required to write correct programs, but it's sane.
+        area = case foldr retBlock (retStmts ss Nothing) other_blocks of
+                 Just (as, _)  -> mkCallArea id as $ Just args
+                 Nothing       -> mkCallArea id [] $ Just args
+        retBlock (BasicBlock _ ss) z = retStmts ss z
+        retStmts [CmmReturn ress] z@(Just (_, n)) =
+          if size ress == n then z
+          else panic "return statements in C-- procs must return the same results"
+        retStmts [CmmReturn ress] Nothing  = Just (ress, size ress)
+        retStmts (_ : rst) z = retStmts rst z
+        retStmts [] z = z
+        size args = areaSize $ mkCallArea id args Nothing

 
 ofZgraph :: CmmGraph -> ListGraph CmmStmt
 ofZgraph g = ListGraph $ swallow blocks
 
 ofZgraph :: CmmGraph -> ListGraph CmmStmt
 ofZgraph g = ListGraph $ swallow blocks

diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index ca69178..3149fb8 100644 (file)
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -8,19 +8,18 @@ module CmmExpr
     , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
     , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
             , plusRegSet, minusRegSet, timesRegSet
     , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
     , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
             , plusRegSet, minusRegSet, timesRegSet

-    , StackSlotMap, getSlot
-    )
-where
+    , Area(..), StackSlotMap, getSlot, mkCallArea, outgoingSlot, areaId, areaSize
+    ) where

 
 

+import BlockId

 import CLabel
 import FiniteMap
 import MachOp
 import CLabel
 import FiniteMap
 import MachOp

+import Maybes

 import Monad
 import Panic
 import Monad
 import Panic

-import StackSlot

 import Unique
 import UniqSet
 import Unique
 import UniqSet

-import UniqSupply

 
 -----------------------------------------------------------------------------
 --             CmmExpr
 
 -----------------------------------------------------------------------------
 --             CmmExpr

@@ -37,14 +36,21 @@ data CmmExpr
        --        ** is shorthand only, meaning **
        -- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
        --      where rep = cmmRegRep reg
        --        ** is shorthand only, meaning **
        -- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
        --      where rep = cmmRegRep reg

+  | CmmStackSlot Area Int

   deriving Eq
 
 data CmmReg 
   = CmmLocal  LocalReg
   | CmmGlobal GlobalReg
   deriving Eq
 
 data CmmReg 
   = CmmLocal  LocalReg
   | CmmGlobal GlobalReg

-  | CmmStack  StackSlot

   deriving( Eq, Ord )
 
   deriving( Eq, Ord )
 

+-- | A stack area is either the stack slot where a variable is spilled
+-- or the stack space where function arguments and results are passed.
+data Area
+  = RegSlot  LocalReg
+  | CallArea BlockId Int Int
+  deriving (Eq, Ord)
+

 data CmmLit
   = CmmInt Integer  MachRep
        -- Interpretation: the 2's complement representation of the value
 data CmmLit
   = CmmInt Integer  MachRep
        -- Interpretation: the 2's complement representation of the value

@@ -119,19 +125,35 @@ timesRegSet      = intersectUniqSets
 --    Stack slots
 -----------------------------------------------------------------------------
 
 --    Stack slots
 -----------------------------------------------------------------------------
 

-mkVarSlot :: Unique -> CmmReg -> StackSlot
-mkVarSlot id r = StackSlot (mkStackArea (mkBlockId id) [r] Nothing) 0
+mkVarSlot :: LocalReg -> CmmExpr
+mkVarSlot r = CmmStackSlot (RegSlot r) 0

 
 -- Usually, we either want to lookup a variable's spill slot in an environment
 -- or else allocate it and add it to the environment.
 -- For a variable, we just need a single area of the appropriate size.
 
 -- Usually, we either want to lookup a variable's spill slot in an environment
 -- or else allocate it and add it to the environment.
 -- For a variable, we just need a single area of the appropriate size.

-type StackSlotMap = FiniteMap CmmReg StackSlot
-getSlot :: MonadUnique m => StackSlotMap -> CmmReg -> m (StackSlotMap, StackSlot)
+type StackSlotMap = FiniteMap LocalReg CmmExpr
+getSlot :: StackSlotMap -> LocalReg -> (StackSlotMap, CmmExpr)

 getSlot map r = case lookupFM map r of
 getSlot map r = case lookupFM map r of

-                  Just s  -> return (map, s)
-                  Nothing -> do id <- getUniqueM
-                                let s = mkVarSlot id r
-                                return (addToFM map r s, s)
+                  Just s  -> (map, s)
+                  Nothing -> (addToFM map r s, s) where s = mkVarSlot r
+
+-- Eventually, we'll want something proper that takes arguments and formals
+-- and gives you back the calling convention code, as well as the stack area.
+mkCallArea :: BlockId -> [a] -> Maybe [b] -> Area
+mkCallArea id as fs = CallArea id (length as) (liftM length fs `orElse` 0)
+
+-- Return the last slot in the outgoing parameter area.
+outgoingSlot :: Area -> CmmExpr
+outgoingSlot a@(RegSlot _) = CmmStackSlot a 0
+outgoingSlot a@(CallArea _ outN _) = CmmStackSlot a outN
+
+areaId :: Area -> BlockId
+areaId (RegSlot _) = panic "Register stack slots don't have IDs!"
+areaId (CallArea id _ _) = id
+
+areaSize :: Area -> Int
+areaSize (RegSlot _) = 1
+areaSize (CallArea _ outN inN) = max outN inN

 
 
 -----------------------------------------------------------------------------
 
 
 -----------------------------------------------------------------------------

@@ -152,12 +174,10 @@ filterRegsUsed p e =
 instance UserOfLocalRegs CmmReg where
     foldRegsUsed f z (CmmLocal reg) = f z reg
     foldRegsUsed _ z (CmmGlobal _)  = z
 instance UserOfLocalRegs CmmReg where
     foldRegsUsed f z (CmmLocal reg) = f z reg
     foldRegsUsed _ z (CmmGlobal _)  = z

-    foldRegsUsed _ z (CmmStack _)  = z

 
 instance DefinerOfLocalRegs CmmReg where
     foldRegsDefd f z (CmmLocal reg) = f z reg
     foldRegsDefd _ z (CmmGlobal _)  = z
 
 instance DefinerOfLocalRegs CmmReg where
     foldRegsDefd f z (CmmLocal reg) = f z reg
     foldRegsDefd _ z (CmmGlobal _)  = z

-    foldRegsDefd _ z (CmmStack _)  = z

 
 instance UserOfLocalRegs LocalReg where
     foldRegsUsed f z r = f z r
 
 instance UserOfLocalRegs LocalReg where
     foldRegsUsed f z r = f z r

@@ -175,6 +195,7 @@ instance UserOfLocalRegs CmmExpr where
           expr z (CmmReg r)          = foldRegsUsed f z r
           expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
           expr z (CmmRegOff r _)     = foldRegsUsed f z r
           expr z (CmmReg r)          = foldRegsUsed f z r
           expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
           expr z (CmmRegOff r _)     = foldRegsUsed f z r

+          expr z (CmmStackSlot _ _)  = z

 
 instance UserOfLocalRegs a => UserOfLocalRegs [a] where
   foldRegsUsed _ set [] = set
 
 instance UserOfLocalRegs a => UserOfLocalRegs [a] where
   foldRegsUsed _ set [] = set

@@ -196,11 +217,11 @@ cmmExprRep (CmmLoad _ rep)   = rep
 cmmExprRep (CmmReg reg)      = cmmRegRep reg
 cmmExprRep (CmmMachOp op _)  = resultRepOfMachOp op
 cmmExprRep (CmmRegOff reg _) = cmmRegRep reg
 cmmExprRep (CmmReg reg)      = cmmRegRep reg
 cmmExprRep (CmmMachOp op _)  = resultRepOfMachOp op
 cmmExprRep (CmmRegOff reg _) = cmmRegRep reg

+cmmExprRep (CmmStackSlot _ _) = wordRep

 
 cmmRegRep :: CmmReg -> MachRep
 cmmRegRep (CmmLocal  reg) = localRegRep reg
 cmmRegRep (CmmGlobal reg)      = globalRegRep reg
 
 cmmRegRep :: CmmReg -> MachRep
 cmmRegRep (CmmLocal  reg) = localRegRep reg
 cmmRegRep (CmmGlobal reg)      = globalRegRep reg

-cmmRegRep (CmmStack  _)          = panic "cmmRegRep not yet defined on stack slots"

 
 localRegRep :: LocalReg -> MachRep
 localRegRep (LocalReg _ rep _) = rep
 
 localRegRep :: LocalReg -> MachRep
 localRegRep (LocalReg _ rep _) = rep

diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 8824de1..293c203 100644 (file)
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -16,6 +16,7 @@ module CmmLint (
   cmmLint, cmmLintTop
   ) where
 
   cmmLint, cmmLintTop
   ) where
 

+import BlockId

 import Cmm
 import CLabel
 import MachOp
 import Cmm
 import CLabel
 import MachOp

diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
index 2450b70..078fcd3 100644 (file)
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/cmm/CmmLive.hs
@@ -14,6 +14,7 @@ module CmmLive (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import BlockId

 import Cmm
 import Dataflow
 
 import Cmm
 import Dataflow
 

diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs
index f4b9b0f..4dc0874 100644 (file)
--- a/compiler/cmm/CmmLiveZ.hs
+++ b/compiler/cmm/CmmLiveZ.hs
@@ -7,13 +7,13 @@ module CmmLiveZ
     ) 
 where
 
     ) 
 where
 

+import BlockId

 import CmmExpr
 import CmmTx
 import DFMonad
 import Monad
 import PprCmm()
 import PprCmmZ()
 import CmmExpr
 import CmmTx
 import DFMonad
 import Monad
 import PprCmm()
 import PprCmmZ()

-import StackSlot

 import ZipCfg
 import ZipDataflow
 import ZipCfgCmmRep
 import ZipCfg
 import ZipDataflow
 import ZipCfgCmmRep

diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 451a153..aa0ef01 100644 (file)
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -11,6 +11,7 @@ module CmmProcPoint (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import BlockId

 import Cmm
 import CmmBrokenBlock
 import Dataflow
 import Cmm
 import CmmBrokenBlock
 import Dataflow

diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 6cc5a76..82d3e26 100644 (file)
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -8,6 +8,7 @@ where
 
 import Prelude hiding (zip, unzip, last)
 
 
 import Prelude hiding (zip, unzip, last)
 

+import BlockId

 import CLabel
 --import ClosureInfo
 import Cmm hiding (blockId)
 import CLabel
 --import ClosureInfo
 import Cmm hiding (blockId)

@@ -17,7 +18,6 @@ import CmmLiveZ
 import CmmTx
 import DFMonad
 import FiniteMap
 import CmmTx
 import DFMonad
 import FiniteMap

-import ForeignCall -- used in protocol for the entry point

 import MachOp (MachHint(NoHint))
 import Maybes
 import MkZipCfgCmm hiding (CmmBlock, CmmGraph)
 import MachOp (MachHint(NoHint))
 import Maybes
 import MkZipCfgCmm hiding (CmmBlock, CmmGraph)

@@ -25,7 +25,6 @@ import Monad
 import Name
 import Outputable
 import Panic
 import Name
 import Outputable
 import Panic

-import StackSlot

 import UniqFM
 import UniqSet
 import UniqSupply
 import UniqFM
 import UniqSet
 import UniqSupply

@@ -230,7 +229,7 @@ algorithm would be just as good, so that's what we do.
 
 -}
 
 
 -}
 

-data Protocol = Protocol Convention CmmFormals StackArea
+data Protocol = Protocol Convention CmmFormals Area

   deriving Eq
 instance Outputable Protocol where
   ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a
   deriving Eq
 instance Outputable Protocol where
   ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a

@@ -239,9 +238,8 @@ instance Outputable Protocol where
 -- points that are relevant to the optimization explained above.
 -- The others are assigned by 'add_unassigned', which is not yet clever.
 
 -- points that are relevant to the optimization explained above.
 -- The others are assigned by 'add_unassigned', which is not yet clever.
 

-addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmFormalsWithoutKinds ->
-                         CmmGraph -> FuelMonad CmmGraph
-addProcPointProtocols callPPs procPoints formals g =
+addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelMonad CmmGraph
+addProcPointProtocols callPPs procPoints g =

   do liveness <- cmmLivenessZ g
      (protos, g') <- return $ optimize_calls liveness g
      blocks'' <- add_CopyOuts protos procPoints g'
   do liveness <- cmmLivenessZ g
      (protos, g') <- return $ optimize_calls liveness g
      blocks'' <- add_CopyOuts protos procPoints g'

@@ -286,12 +284,8 @@ addProcPointProtocols callPPs procPoints formals g =
           maybe_add_proto :: CmmBlock -> BlockEnv Protocol -> BlockEnv Protocol
           maybe_add_proto (Block id (ZTail (CopyIn c fs _srt) _)) env =
               extendBlockEnv env id (Protocol c fs $ toArea id fs)
           maybe_add_proto :: CmmBlock -> BlockEnv Protocol -> BlockEnv Protocol
           maybe_add_proto (Block id (ZTail (CopyIn c fs _srt) _)) env =
               extendBlockEnv env id (Protocol c fs $ toArea id fs)

-          maybe_add_proto (Block id _) env | id == lg_entry g =
-              extendBlockEnv env id (Protocol stdArgConvention hfs $ toArea id hfs)

           maybe_add_proto _ env = env
           maybe_add_proto _ env = env

-          toArea id fs = mkStackArea id fs $ Just fs
-          hfs = map (\x -> CmmKinded x NoHint) formals
-          stdArgConvention = ConventionStandard CmmCallConv Arguments
+          toArea id fs = mkCallArea id fs $ Just fs

 
 -- | For now, following a suggestion by Ben Lippmeier, we pass all
 -- live variables as arguments, hoping that a clever register
 
 -- | For now, following a suggestion by Ben Lippmeier, we pass all
 -- live variables as arguments, hoping that a clever register

@@ -313,7 +307,7 @@ pass_live_vars_as_args liveness procPoints protos = protos'
                                     panic ("no liveness at block " ++ show id)
                              formals = map (\x -> CmmKinded x NoHint) $ uniqSetToList live
                              prot = Protocol ConventionPrivate formals $
                                     panic ("no liveness at block " ++ show id)
                              formals = map (\x -> CmmKinded x NoHint) $ uniqSetToList live
                              prot = Protocol ConventionPrivate formals $

-                                             mkStackArea id formals $ Just formals
+                                             mkCallArea id formals $ Just formals

                          in  extendBlockEnv protos id prot
 
 
                          in  extendBlockEnv protos id prot
 
 

@@ -343,10 +337,10 @@ add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph ->
 add_CopyOuts protos procPoints g = fold_blocks maybe_insert_CopyOut (return emptyBlockEnv) g
     where maybe_insert_CopyOut :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) ->
                                   FuelMonad (BlockEnv CmmBlock)
 add_CopyOuts protos procPoints g = fold_blocks maybe_insert_CopyOut (return emptyBlockEnv) g
     where maybe_insert_CopyOut :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) ->
                                   FuelMonad (BlockEnv CmmBlock)

-          maybe_insert_CopyOut b@(Block bid _) blocks =
+          maybe_insert_CopyOut b@(Block bid _) blocks | bid == lg_entry g = skip b blocks 
+          maybe_insert_CopyOut b blocks =

             case last $ unzip b of
             case last $ unzip b of

-              LastOther (LastCall _ _) -> -- skip calls (copy out done by callee)
-                 blocks >>= (\bmap -> return $ extendBlockEnv bmap bid b)
+              LastOther (LastCall _ _) -> skip b blocks -- copy out done by callee

               _ -> maybe_insert_CopyOut' b blocks
           maybe_insert_CopyOut' b blocks = fold_succs trySucc b init >>= finish
             where init = blocks >>= (\bmap -> return (b, bmap))
               _ -> maybe_insert_CopyOut' b blocks
           maybe_insert_CopyOut' b blocks = fold_succs trySucc b init >>= finish
             where init = blocks >>= (\bmap -> return (b, bmap))

@@ -364,6 +358,8 @@ add_CopyOuts protos procPoints g = fold_blocks maybe_insert_CopyOut (return empt
                        (b, bs)   <- insertBetween b m succId
                        return $ (b, foldl (flip insertBlock) bmap bs)
                   finish (b@(Block bid _), bmap) = return $ extendBlockEnv bmap bid b
                        (b, bs)   <- insertBetween b m succId
                        return $ (b, foldl (flip insertBlock) bmap bs)
                   finish (b@(Block bid _), bmap) = return $ extendBlockEnv bmap bid b

+          skip b@(Block bid _) bs = bs >>= (\bmap -> return $ extendBlockEnv bmap bid b)
+

 
 
 -- Input invariant: A block should only be reachable from a single ProcPoint.
 
 
 -- Input invariant: A block should only be reachable from a single ProcPoint.

diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs
index 2b54b9a..3cc102f 100644 (file)
--- a/compiler/cmm/CmmSpillReload.hs
+++ b/compiler/cmm/CmmSpillReload.hs
@@ -15,6 +15,7 @@ module CmmSpillReload
   )
 where
 
   )
 where
 

+import BlockId

 import CmmExpr
 import CmmTx
 import CmmLiveZ
 import CmmExpr
 import CmmTx
 import CmmLiveZ

@@ -22,7 +23,6 @@ import DFMonad
 import MkZipCfg
 import OptimizationFuel
 import PprCmm()
 import MkZipCfg
 import OptimizationFuel
 import PprCmm()

-import StackSlot

 import ZipCfg
 import ZipCfgCmmRep
 import ZipDataflow
 import ZipCfg
 import ZipCfgCmmRep
 import ZipDataflow

@@ -151,19 +151,19 @@ gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
 gen  a live = foldRegsUsed extendRegSet      live a
 kill a live = foldRegsUsed delOneFromUniqSet live a
 
 gen  a live = foldRegsUsed extendRegSet      live a
 kill a live = foldRegsUsed delOneFromUniqSet live a
 

-insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites M Last DualLive Graph
+insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites M Last DualLive

 insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
     where middle = middleInsertSpillsAndReloads
           last   = \_ _ -> Nothing
           exit = Nothing
           first live id =
             if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then
 insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
     where middle = middleInsertSpillsAndReloads
           last   = \_ _ -> Nothing
           exit = Nothing
           first live id =
             if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then

-              Just $ graphOfMiddles $ [Reload reloads]
+              Just $ mkMiddles $ [Reload reloads]

             else Nothing
               where reloads = in_regs live
 
 
             else Nothing
               where reloads = in_regs live
 
 

-middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last)
+middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (AGraph M Last)

 middleInsertSpillsAndReloads _ (Spill _)  = Nothing
 middleInsertSpillsAndReloads _ (Reload _) = Nothing
 middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr
 middleInsertSpillsAndReloads _ (Spill _)  = Nothing
 middleInsertSpillsAndReloads _ (Reload _) = Nothing
 middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr

@@ -171,7 +171,7 @@ middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr
             if reg `elemRegSet` on_stack live then -- must spill
                 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
                                             text "after", ppr m]) $
             if reg `elemRegSet` on_stack live then -- must spill
                 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
                                             text "after", ppr m]) $

-                Just $ graphOfMiddles [m, Spill $ mkRegSet [reg]]
+                Just $ mkMiddles [m, Spill $ mkRegSet [reg]]

             else
                 Nothing
         middle (CopyIn _ formals _) = 
             else
                 Nothing
         middle (CopyIn _ formals _) = 

@@ -192,31 +192,26 @@ middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr
                                                  ppr (Reload regs' :: M),
                                                  ppr (Spill needs_spilling :: M),
                                                  text "after", ppr m]) $
                                                  ppr (Reload regs' :: M),
                                                  ppr (Spill needs_spilling :: M),
                                                  text "after", ppr m]) $

-                    Just $ graphOfMiddles (m : code')
+                    Just $ mkMiddles (m : code')

         middle _ = Nothing
                       
 -- | For conversion back to vanilla C--
 
         middle _ = Nothing
                       
 -- | For conversion back to vanilla C--
 

-elimSpillAndReload :: StackSlotMap -> LGraph M l -> FuelMonad (StackSlotMap, LGraph Middle l)
-elimSpillAndReload slots g = fold_blocks block (return (slots, [])) g >>= toGraph
-  where toGraph (slots, l) = return (slots, of_block_list (lg_entry g) l)
-        block (Block id t) z =
-          do (slots, blocks) <- z
-             (slots, t)      <- tail t slots
-             return (slots, Block id t : blocks)
-        tail (ZLast l)   slots = return (slots, ZLast l)
-        tail (ZTail m t) slots =
-          do (slots, t) <- tail t slots
-             middle m t slots
-        middle (Spill  regs) t slots = foldUniqSet spill  (return (slots, t)) regs
-        middle (Reload regs) t slots = foldUniqSet reload (return (slots, t)) regs
-        middle (NotSpillOrReload m) t slots = return (slots, ZTail m t)
-        move f r z = do let reg = CmmLocal r
-                        (slots, t) <- z
-                        (slots, slot) <- getSlot slots reg
-                        return (slots, ZTail (f (CmmStack slot) reg) t)
-        spill  = move (\ slot reg -> MidAssign slot (CmmReg reg))
-        reload = move (\ slot reg -> MidAssign reg  (CmmReg slot))
+elimSpillAndReload :: StackSlotMap -> LGraph M l -> (StackSlotMap, LGraph Middle l)
+elimSpillAndReload slots g = toGraph $ fold_blocks block ((slots, [])) g
+  where toGraph (slots, l) = (slots, of_block_list (lg_entry g) l)
+        block (Block id t) (slots, blocks) =
+          lift (\ t' -> Block id t' : blocks) $ tail t slots
+        tail (ZLast l)   slots = (slots, ZLast l)
+        tail (ZTail m t) slots = middle m $ tail t slots
+        middle (NotSpillOrReload m) (slots, t) = (slots, ZTail m t)
+        middle (Spill  regs)        z          = foldUniqSet spill  z regs
+        middle (Reload regs)        z          = foldUniqSet reload z regs
+        move f r (slots, t) =
+          lift (\ slot -> ZTail (f slot (CmmLocal r)) t) $ getSlot slots r
+        spill  = move (\ slot reg -> MidStore  slot (CmmReg reg))
+        reload = move (\ slot reg -> MidAssign reg slot)
+        lift f (slots, x) = (slots, f x)

 
 
 ----------------------------------------------------------------
 
 
 ----------------------------------------------------------------

@@ -334,15 +329,15 @@ insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
           bot = fact_bot availRegsLattice
           rewrites = ForwardRewrites first middle last exit
           first _ _ = Nothing
           bot = fact_bot availRegsLattice
           rewrites = ForwardRewrites first middle last exit
           first _ _ = Nothing

-          middle :: AvailRegs -> M -> Maybe (Graph M Last)
-          last   :: AvailRegs -> Last -> Maybe (Graph M Last)
+          middle :: AvailRegs -> M -> Maybe (AGraph M Last)
+          last   :: AvailRegs -> Last -> Maybe (AGraph M Last)

           middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
           last avail l   = maybe_reload_before avail l (ZLast (LastOther l))
           exit _ = Nothing
           maybe_reload_before avail node tail =
               let used = filterRegsUsed (elemAvail avail) node
               in  if isEmptyUniqSet used then Nothing
           middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
           last avail l   = maybe_reload_before avail l (ZLast (LastOther l))
           exit _ = Nothing
           maybe_reload_before avail node tail =
               let used = filterRegsUsed (elemAvail avail) node
               in  if isEmptyUniqSet used then Nothing

-                  else Just $ graphOfZTail $ ZTail (Reload used) tail
+                  else Just $ mkZTail $ ZTail (Reload used) tail

           
 removeDeadAssignmentsAndReloads :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
 removeDeadAssignmentsAndReloads procPoints g =
           
 removeDeadAssignmentsAndReloads :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
 removeDeadAssignmentsAndReloads procPoints g =

@@ -356,18 +351,18 @@ removeDeadAssignmentsAndReloads procPoints g =
            middle = middleRemoveDeads
            first _ _ = Nothing
 
            middle = middleRemoveDeads
            first _ _ = Nothing
 

-middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
+middleRemoveDeads :: DualLive -> M -> Maybe (AGraph M Last)

 middleRemoveDeads _ (Spill _)  = Nothing
 middleRemoveDeads live (Reload s) =
     if sizeUniqSet worth_reloading < sizeUniqSet s then
 middleRemoveDeads _ (Spill _)  = Nothing
 middleRemoveDeads live (Reload s) =
     if sizeUniqSet worth_reloading < sizeUniqSet s then

-        Just $ if isEmptyUniqSet worth_reloading then emptyGraph
-               else graphOfMiddles [Reload worth_reloading]
+        Just $ if isEmptyUniqSet worth_reloading then emptyAGraph
+               else mkMiddles [Reload worth_reloading]

     else
         Nothing
   where worth_reloading = intersectUniqSets s (in_regs live)
 middleRemoveDeads live (NotSpillOrReload m) = middle m 
   where middle (MidAssign (CmmLocal reg') _)
     else
         Nothing
   where worth_reloading = intersectUniqSets s (in_regs live)
 middleRemoveDeads live (NotSpillOrReload m) = middle m 
   where middle (MidAssign (CmmLocal reg') _)

-               | not (reg' `elemRegSet` in_regs live) = Just emptyGraph
+               | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph

         middle _ = Nothing
                       
 
         middle _ = Nothing
                       
 

diff --git a/compiler/cmm/CmmZipUtil.hs b/compiler/cmm/CmmZipUtil.hs
index dce9e72..aa547e9 100644 (file)
--- a/compiler/cmm/CmmZipUtil.hs
+++ b/compiler/cmm/CmmZipUtil.hs
@@ -4,8 +4,8 @@ module CmmZipUtil
   , givesUniquePredecessorTo
   )
 where
   , givesUniquePredecessorTo
   )
 where

+import BlockId

 import Prelude hiding (last, unzip)
 import Prelude hiding (last, unzip)

-import StackSlot

 import ZipCfg
 
 import Maybes
 import ZipCfg
 
 import Maybes

diff --git a/compiler/cmm/DFMonad.hs b/compiler/cmm/DFMonad.hs
index 7412969..3df5b68 100644 (file)
--- a/compiler/cmm/DFMonad.hs
+++ b/compiler/cmm/DFMonad.hs
@@ -12,10 +12,10 @@ module DFMonad
     )
 where
 
     )
 where
 

+import BlockId

 import CmmTx
 import PprCmm()
 import OptimizationFuel
 import CmmTx
 import PprCmm()
 import OptimizationFuel

-import StackSlot

 
 import Control.Monad
 import Maybes
 
 import Control.Monad
 import Maybes

diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs
index 73f7b5a..b405352 100644 (file)
--- a/compiler/cmm/MkZipCfg.hs
+++ b/compiler/cmm/MkZipCfg.hs
@@ -9,7 +9,7 @@ module MkZipCfg
     )
 where
 
     )
 where
 

-import StackSlot
+import BlockId (BlockId(..), emptyBlockEnv)

 import ZipCfg
 
 import Outputable
 import ZipCfg
 
 import Outputable

diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs
index 2600da2..e623c30 100644 (file)
--- a/compiler/cmm/MkZipCfgCmm.hs
+++ b/compiler/cmm/MkZipCfgCmm.hs
@@ -19,16 +19,16 @@ where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import BlockId

 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
            , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds
            , CmmKinded (..)
            )
 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
            , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds
            , CmmKinded (..)
            )

-import MachOp (MachHint(..))
+import MachOp (MachHint(..), wordRep)

 import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
   -- ^ to make this module more self-contained, these definitions are duplicated below
 import PprCmm()
 import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
   -- ^ to make this module more self-contained, these definitions are duplicated below
 import PprCmm()

-import StackSlot

 
 import ClosureInfo
 import FastString
 
 import ClosureInfo
 import FastString

@@ -62,10 +62,10 @@ mkFinalCall  :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
 mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
 
 ---------- Control transfer
 mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
 
 ---------- Control transfer

-mkJump         :: CmmExpr -> CmmActuals -> CmmAGraph
-mkCbranch      :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
-mkSwitch       :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
-mkReturn       :: CmmActuals -> CmmAGraph
+mkJump         :: Area    -> CmmExpr -> CmmActuals -> CmmAGraph
+mkCbranch      :: CmmExpr -> BlockId -> BlockId    -> CmmAGraph
+mkSwitch       :: CmmExpr -> [Maybe BlockId]       -> CmmAGraph
+mkReturn       :: Area    -> CmmActuals            -> CmmAGraph

 
 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
 
 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph

@@ -105,23 +105,22 @@ mkSwitch e tbl            = mkLast   $ LastSwitch e tbl
 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
 mkAddToContext ra actuals        = mkMiddle $ MidAddToContext ra actuals
 
 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
 mkAddToContext ra actuals        = mkMiddle $ MidAddToContext ra actuals
 

---cmmArgConv :: Convention

 cmmResConv :: Convention
 cmmResConv :: Convention

---cmmArgConv = ConventionStandard CmmCallConv Arguments
-cmmResConv = ConventionStandard CmmCallConv Arguments
+cmmResConv = ConventionStandard CmmCallConv Results

 
 

-copyIn :: Convention -> StackArea -> CmmFormals -> [Middle]
+copyIn :: Convention -> Area -> CmmFormals -> [Middle]

 copyIn _ area formals = reverse $ snd $ foldl ci (1, []) formals
   where ci (n, ms) v = (n+1, MidAssign (CmmLocal $ kindlessCmm v)
 copyIn _ area formals = reverse $ snd $ foldl ci (1, []) formals
   where ci (n, ms) v = (n+1, MidAssign (CmmLocal $ kindlessCmm v)

-                                       (CmmReg $ CmmStack $ StackSlot area n) : ms)
-
-copyOut :: Convention -> StackArea -> CmmActuals -> [Middle]
-copyOut _ area actuals = moveSP : reverse (snd $ foldl co (1, []) actuals)
-  where moveSP = MidAssign spReg $ CmmReg $ CmmStack $ outgoingSlot area
-        co (n, ms) v = (n+1, MidAssign (CmmStack $ StackSlot area n) 
-                                       (kindlessCmm v) : ms)
-mkEntry :: BlockId -> Convention -> CmmFormalsWithoutKinds -> [Middle]
-mkEntry entryId conv formals = copyIn conv (mkStackArea entryId [] $ Just fs) fs
+                                       (CmmLoad (CmmStackSlot area n) wordRep) : ms)
+
+copyOut :: Convention -> Area -> CmmActuals -> [Middle]
+copyOut conv area actuals = moveSP conv $ snd $ foldl co (1, []) actuals
+  where moveSP (ConventionStandard _ Arguments) args =
+           MidAssign spReg (outgoingSlot area) : reverse args
+        moveSP _ args = reverse $ MidAssign spReg (outgoingSlot area) : args
+        co (n, ms) v = (n+1, MidStore (CmmStackSlot area n) (kindlessCmm v) : ms)
+mkEntry :: Area -> Convention -> CmmFormalsWithoutKinds -> [Middle]
+mkEntry area conv formals = copyIn conv area fs

   where fs = map (\f -> CmmKinded f NoHint) formals
 
 -- I'm not sure how to get the calling conventions right yet,
   where fs = map (\f -> CmmKinded f NoHint) formals
 
 -- I'm not sure how to get the calling conventions right yet,

@@ -129,31 +128,32 @@ mkEntry entryId conv formals = copyIn conv (mkStackArea entryId [] $ Just fs) fs
 -- Simon's patch is applied.
 -- For now, I apply a bogus calling convention: all arguments go on the
 -- stack, using the same amount of stack space.
 -- Simon's patch is applied.
 -- For now, I apply a bogus calling convention: all arguments go on the
 -- stack, using the same amount of stack space.

-lastWithArgs :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) ->
-                CmmAGraph
-lastWithArgs conv actuals formals toLast =
-  withFreshLabel "call successor" $ \k ->
-    let area = mkStackArea k actuals formals
-    in (mkMiddles $ copyOut conv area actuals) <*>
-       -- adjust the sp
-       mkLast (toLast k) <*>
-       case formals of
-         Just formals -> mkLabel k <*> (mkMiddles $ copyIn conv area formals)
-         Nothing      -> emptyAGraph
+lastWithArgs' :: BlockId -> Area -> Convention -> CmmActuals -> Maybe CmmFormals ->
+                 (BlockId -> Last) -> CmmAGraph
+lastWithArgs' k area conv actuals formals toLast =
+  (mkMiddles $ copyOut conv area actuals) <*>
+  -- adjust the sp
+  mkLast (toLast k) <*>
+  case formals of
+    Just formals -> mkLabel k <*> (mkMiddles $ copyIn conv area formals)
+    Nothing      -> emptyAGraph
+lastWithArgs :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) -> CmmAGraph
+lastWithArgs c a f l =
+  withFreshLabel "call successor" $ \k -> lastWithArgs' k (mkCallArea k a f) c a f l
+

 always :: a -> b -> a
 always x _ = x
 
 always :: a -> b -> a
 always x _ = x
 

-mkJump e actuals = lastWithArgs cmmResConv actuals Nothing $ always $ LastJump e
-mkReturn actuals = lastWithArgs cmmResConv actuals Nothing $ always LastReturn
---mkJump e actuals = mkMiddle (CopyOut cmmArgConv actuals) <*> mkLast (LastJump e)
---mkReturn actuals = mkMiddle (CopyOut cmmResConv actuals) <*> mkLast LastReturn
+-- The area created for the jump and return arguments is the same area as the
+-- procedure entry.
+mkJump   area e actuals =
+  lastWithArgs' (areaId area) area cmmResConv actuals Nothing $ always $ LastJump e
+mkReturn area   actuals =
+  lastWithArgs' (areaId area) area cmmResConv actuals Nothing $ always LastReturn

 
 mkFinalCall f conv actuals =
   lastWithArgs (ConventionStandard conv Arguments) actuals Nothing
       $ always $ LastCall f Nothing --mkFinalCall  f conv actuals =
 
 mkFinalCall f conv actuals =
   lastWithArgs (ConventionStandard conv Arguments) actuals Nothing
       $ always $ LastCall f Nothing --mkFinalCall  f conv actuals =

---    mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
---    mkLast   (LastCall f Nothing)
---

 
 mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
 
 
 mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
 

@@ -161,9 +161,3 @@ mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
 mkCall f conv results actuals _ =
   lastWithArgs (ConventionStandard conv Arguments) actuals (Just results)
         $ \k -> LastCall f (Just k)
 mkCall f conv results actuals _ =
   lastWithArgs (ConventionStandard conv Arguments) actuals (Just results)
         $ \k -> LastCall f (Just k)

---mkCall f conv results actuals srt = 
---    withFreshLabel "call successor" $ \k ->
---      mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
---      mkLast (LastCall f (Just k)) <*>
---      mkLabel k <*>
---      mkMiddle (CopyIn (ConventionStandard conv Results) results srt)

diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs
index 7ec9d48..3d5b645 100644 (file)
--- a/compiler/cmm/OptimizationFuel.hs
+++ b/compiler/cmm/OptimizationFuel.hs
@@ -5,24 +5,17 @@ module OptimizationFuel
     , FuelConsumer
     , FuelUsingMonad, FuelState
     , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement, fuelDec1
     , FuelConsumer
     , FuelUsingMonad, FuelState
     , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement, fuelDec1

-    --, lastFuelPassInState , fuelExhaustedInState, fuelRemainingInState
-    --, fuelDecrementState
-    --, runFuel
-    , runFuelIO
-    --, runFuelWithLastPass
-    , fuelConsumingPass
+    , runFuelIO, fuelConsumingPass

     , FuelMonad
     , liftUniq
     , lGraphOfGraph -- needs to be able to create a unique ID...
     )
 where
 
     , FuelMonad
     , liftUniq
     , lGraphOfGraph -- needs to be able to create a unique ID...
     )
 where
 

-import StackSlot
+import BlockId

 import ZipCfg
 import ZipCfg

-

 --import GHC.Exts (State#)
 import Panic
 --import GHC.Exts (State#)
 import Panic

-

 import Data.IORef
 import Monad
 import StaticFlags (opt_Fuel)
 import Data.IORef
 import Monad
 import StaticFlags (opt_Fuel)

@@ -139,28 +132,3 @@ lGraphOfGraph :: Graph m l -> FuelMonad (LGraph m l)
 lGraphOfGraph (Graph tail blocks) =
   do entry <- liftM BlockId $ getUniqueM
      return $ LGraph entry (insertBlock (Block entry tail) blocks)
 lGraphOfGraph (Graph tail blocks) =
   do entry <- liftM BlockId $ getUniqueM
      return $ LGraph entry (insertBlock (Block entry tail) blocks)

-
-
--- JD: I'm not sure what NR's plans are for the following code.
--- Perhaps these functions will be useful in the future, or perhaps I've made
--- them obsoltete.
-
---initialFuelState :: OptimizationFuel -> FuelState
---initialFuelState fuel = FuelState fuel "unoptimized program"
---runFuel             :: FuelMonad a -> FuelConsumer a
---runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
-
---runFuel             (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
---                                         in (a, fs_fuellimit s)
---runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
---                                         in ((a, fs_lastpass s), fs_fuellimit s)
-
--- lastFuelPassInState :: FuelState -> String
--- lastFuelPassInState = fs_lastpass
-
--- fuelExhaustedInState :: FuelState -> Bool
--- fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit
-
--- fuelRemainingInState :: FuelState -> OptimizationFuel
--- fuelRemainingInState = fs_fuellimit
-

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index a0661cd..37359ed 100644 (file)
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -33,6 +33,7 @@ module PprC (
 #include "HsVersions.h"
 
 -- Cmm stuff
 #include "HsVersions.h"
 
 -- Cmm stuff

+import BlockId

 import Cmm
 import PprCmm  ()      -- Instances only
 import CLabel
 import Cmm
 import PprCmm  ()      -- Instances only
 import CLabel

diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 150ffb9..dbfd20e 100644 (file)
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -37,8 +37,8 @@ module PprCmm
     )
 where
 
     )
 where
 

+import BlockId

 import Cmm
 import Cmm

-import CmmExpr

 import CmmUtils
 import MachOp
 import CLabel
 import CmmUtils
 import MachOp
 import CLabel

@@ -91,6 +91,9 @@ instance Outputable CmmLit where
 instance Outputable LocalReg where
     ppr e = pprLocalReg e
 
 instance Outputable LocalReg where
     ppr e = pprLocalReg e
 

+instance Outputable Area where
+    ppr e = pprArea e
+

 instance Outputable GlobalReg where
     ppr e = pprGlobalReg e
 
 instance Outputable GlobalReg where
     ppr e = pprGlobalReg e
 

@@ -435,7 +438,8 @@ pprExpr9 e =
         CmmLit    lit       -> pprLit1 lit
         CmmLoad   expr rep  -> ppr rep <> brackets( ppr expr )
         CmmReg    reg       -> ppr reg
         CmmLit    lit       -> pprLit1 lit
         CmmLoad   expr rep  -> ppr rep <> brackets( ppr expr )
         CmmReg    reg       -> ppr reg

-        CmmRegOff reg off   -> parens (ppr reg <+> char '+' <+> int off)
+        CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)
+        CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)

        CmmMachOp mop args  -> genMachOp mop args
 
 genMachOp :: MachOp -> [CmmExpr] -> SDoc
        CmmMachOp mop args  -> genMachOp mop args
 
 genMachOp :: MachOp -> [CmmExpr] -> SDoc

@@ -525,7 +529,6 @@ pprReg r
     = case r of
         CmmLocal  local  -> pprLocalReg  local
         CmmGlobal global -> pprGlobalReg global
     = case r of
         CmmLocal  local  -> pprLocalReg  local
         CmmGlobal global -> pprGlobalReg global

-        CmmStack  slot   -> ppr slot

 
 --
 -- We only print the type of the local reg if it isn't wordRep
 
 --
 -- We only print the type of the local reg if it isn't wordRep

@@ -540,6 +543,12 @@ pprLocalReg (LocalReg uniq rep follow)
                 then empty
                 else doubleQuotes (text "ptr")
 
                 then empty
                 else doubleQuotes (text "ptr")
 

+-- Stack areas
+pprArea :: Area -> SDoc
+pprArea (RegSlot r)    = hcat [ text "slot<", ppr r, text ">" ]
+pprArea (CallArea id n n') =
+  hcat [ text "callslot<", ppr id, char '+', ppr n, char '/', ppr n', text ">" ]
+

 -- needs to be kept in syn with Cmm.hs.GlobalReg
 --
 pprGlobalReg :: GlobalReg -> SDoc
 -- needs to be kept in syn with Cmm.hs.GlobalReg
 --
 pprGlobalReg :: GlobalReg -> SDoc

diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs
index 4e9d2b6..1e5f52f 100644 (file)
--- a/compiler/cmm/PprCmmZ.hs
+++ b/compiler/cmm/PprCmmZ.hs
@@ -4,12 +4,12 @@ module PprCmmZ
     )
 where
 
     )
 where
 

+import BlockId

 import Cmm
 import CmmExpr
 import ForeignCall
 import PprCmm
 import Outputable
 import Cmm
 import CmmExpr
 import ForeignCall
 import PprCmm
 import Outputable

-import StackSlot

 import qualified ZipCfgCmmRep as G
 import qualified ZipCfg as Z
 import CmmZipUtil
 import qualified ZipCfgCmmRep as G
 import qualified ZipCfg as Z
 import CmmZipUtil

diff --git a/compiler/cmm/StackColor.hs b/compiler/cmm/StackColor.hs
index d43a834..4d544bd 100644 (file)
--- a/compiler/cmm/StackColor.hs
+++ b/compiler/cmm/StackColor.hs
@@ -1,6 +1,7 @@
 
 module StackColor where
 
 
 module StackColor where
 

+import BlockId

 import StackPlacements
 import qualified GraphColor as Color
 import CmmExpr
 import StackPlacements
 import qualified GraphColor as Color
 import CmmExpr

@@ -8,7 +9,6 @@ import CmmSpillReload
 import DFMonad
 import qualified GraphOps
 import MachOp
 import DFMonad
 import qualified GraphOps
 import MachOp

-import StackSlot

 import ZipCfg
 import ZipCfgCmmRep
 import ZipDataflow
 import ZipCfg
 import ZipCfgCmmRep
 import ZipDataflow

diff --git a/compiler/cmm/StackSlot.hs b/compiler/cmm/StackSlot.hs
deleted file mode 100644 (file)
index abf5bd4..0000000
--- a/compiler/cmm/StackSlot.hs
+++ /dev/null
@@ -1,97 +0,0 @@
-module StackSlot
-    ( BlockId(..), mkBlockId   -- ToDo: BlockId should be abstract, but it isn't yet
-    , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
-    , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, sizeBlockSet, mkBlockSet
-    , StackArea, mkStackArea, outgoingSlot
-    , StackSlot(..)) where -- StackSlot should probably be abstract
--- Why is the BlockId here? To avoid recursive module problems.
-
-import Monad
-import Outputable
-import Unique
-import UniqFM
-import UniqSet
-
-
--- A stack area is represented by three pieces:
--- o The BlockId of the return site.
---   Maybe during the conversion to VFP offsets, this BlockId will be the entry point.
--- o The size of the outgoing parameter space
--- o The size of the incoming parameter space, if the function returns
-data StackArea = StackArea BlockId Int (Maybe Int)
-  deriving (Eq, Ord)
-
-instance Outputable StackArea where
-  ppr (StackArea bid f a) =
-    text "StackArea" <+> ppr bid <+> text "[" <+> ppr f <+> text "," <+> ppr a <+> text ")"
-
--- Eventually, we'll want something proper that takes arguments and formals
--- and gives you back the calling convention code, as well as the stack area.
---mkStackArea :: BlockId -> CmmActuals -> CmmFormals -> (StackArea, ...)
--- But for now...
-mkStackArea :: BlockId -> [a] -> Maybe [b] -> StackArea
-mkStackArea k as fs = StackArea k (length as) (liftM length fs)
-
--- A stack slot is an offset from the base of a stack area.
-data StackSlot = StackSlot StackArea Int
-  deriving (Eq, Ord)
-
--- Return the last slot in the outgoing parameter area.
-outgoingSlot :: StackArea -> StackSlot
-outgoingSlot a@(StackArea _ outN _) = StackSlot a outN
-
-instance Outputable StackSlot where
-  ppr (StackSlot (StackArea bid _ _) n) =
-    text "Stack(" <+> ppr bid <+> text "," <+> ppr n <+> text ")"
-
-
-----------------------------------------------------------------
---- Block Ids, their environments, and their sets
-
-{- Note [Unique BlockId]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Although a 'BlockId' is a local label, for reasons of implementation,
-'BlockId's must be unique within an entire compilation unit.  The reason
-is that each local label is mapped to an assembly-language label, and in
-most assembly languages allow, a label is visible throughout the enitre
-compilation unit in which it appears.
--}
-
-newtype BlockId = BlockId Unique
-  deriving (Eq,Ord)
-
-instance Uniquable BlockId where
-  getUnique (BlockId u) = u
-
-mkBlockId :: Unique -> BlockId
-mkBlockId uniq = BlockId uniq
-
-instance Show BlockId where
-  show (BlockId u) = show u
-
-instance Outputable BlockId where
-  ppr = ppr . getUnique
-
-
-type BlockEnv a = UniqFM {- BlockId -} a
-emptyBlockEnv :: BlockEnv a
-emptyBlockEnv = emptyUFM
-mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
-mkBlockEnv = listToUFM
-lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
-lookupBlockEnv = lookupUFM
-extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
-extendBlockEnv = addToUFM
-
-type BlockSet = UniqSet BlockId
-emptyBlockSet :: BlockSet
-emptyBlockSet = emptyUniqSet
-elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet = elementOfUniqSet
-extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet = addOneToUniqSet
-mkBlockSet :: [BlockId] -> BlockSet
-mkBlockSet = mkUniqSet
-sizeBlockSet :: BlockSet -> Int
-sizeBlockSet = sizeUniqSet
-

diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs
index c7aa1ff..3285b5b 100644 (file)
--- a/compiler/cmm/ZipCfg.hs
+++ b/compiler/cmm/ZipCfg.hs
@@ -36,8 +36,9 @@ where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv
+               , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet)

 import CmmExpr ( UserOfLocalRegs(..) ) --for an instance
 import CmmExpr ( UserOfLocalRegs(..) ) --for an instance

-import StackSlot

 
 import Outputable hiding (empty)
 import Panic
 
 import Outputable hiding (empty)
 import Panic

diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index 31c1fdf..af62168 100644 (file)
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -12,6 +12,7 @@ module ZipCfgCmmRep
   )
 where
 
   )
 where
 

+import BlockId

 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
            , CmmCallTarget(..), CmmActuals, CmmFormals, CmmKinded(..)
 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
            , CmmCallTarget(..), CmmActuals, CmmFormals, CmmKinded(..)

@@ -28,7 +29,6 @@ import ClosureInfo
 import FastString
 import ForeignCall
 import MachOp
 import FastString
 import ForeignCall
 import MachOp

-import StackSlot

 import qualified ZipCfg as Z
 import qualified ZipDataflow as DF
 import ZipCfg 
 import qualified ZipCfg as Z
 import qualified ZipDataflow as DF
 import ZipCfg 

diff --git a/compiler/cmm/ZipCfgExtras.hs b/compiler/cmm/ZipCfgExtras.hs
index b414d39..bd26aca 100644 (file)
--- a/compiler/cmm/ZipCfgExtras.hs
+++ b/compiler/cmm/ZipCfgExtras.hs
@@ -12,9 +12,9 @@
 module ZipCfgExtras
   ()
 where
 module ZipCfgExtras
   ()
 where

+import BlockId

 import Maybes
 import Panic
 import Maybes
 import Panic

-import StackSlot

 import ZipCfg
 
 import Prelude hiding (zip, unzip, last)
 import ZipCfg
 
 import Prelude hiding (zip, unzip, last)

diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs
index b080adc..8365cab 100644 (file)
--- a/compiler/cmm/ZipDataflow.hs
+++ b/compiler/cmm/ZipDataflow.hs
@@ -17,10 +17,10 @@ module ZipDataflow
     )
 where
 
     )
 where
 

+import BlockId

 import CmmTx
 import DFMonad
 import MkZipCfg
 import CmmTx
 import DFMonad
 import MkZipCfg

-import StackSlot

 import ZipCfg
 import qualified ZipCfg as G
 
 import ZipCfg
 import qualified ZipCfg as G
 

@@ -150,21 +150,21 @@ newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
 -- but it might be worth simplifying this module by replacing this type
 -- parameter with AGraph everywhere (SLPJ 19 May 2008).
 
 -- but it might be worth simplifying this module by replacing this type
 -- parameter with AGraph everywhere (SLPJ 19 May 2008).
 

-data BackwardRewrites middle last a g = BackwardRewrites
-    { br_first  :: a              -> BlockId -> Maybe (g middle last)
-    , br_middle :: a              -> middle  -> Maybe (g middle last)
-    , br_last   :: (BlockId -> a) -> last    -> Maybe (g middle last)
-    , br_exit   ::                              Maybe (g middle last)
+data BackwardRewrites middle last a = BackwardRewrites
+    { br_first  :: a              -> BlockId -> Maybe (AGraph middle last)
+    , br_middle :: a              -> middle  -> Maybe (AGraph middle last)
+    , br_last   :: (BlockId -> a) -> last    -> Maybe (AGraph middle last)
+    , br_exit   ::                              Maybe (AGraph middle last)

     } 
 
 -- | A forward rewrite takes the same inputs as a forward transfer,
 -- but instead of producing a fact, it produces a replacement graph or Nothing.
 
     } 
 
 -- | A forward rewrite takes the same inputs as a forward transfer,
 -- but instead of producing a fact, it produces a replacement graph or Nothing.
 

-data ForwardRewrites middle last a g = ForwardRewrites
-    { fr_first  :: a -> BlockId -> Maybe (g middle last)
-    , fr_middle :: a -> middle  -> Maybe (g middle last)
-    , fr_last   :: a -> last    -> Maybe (g middle last)
-    , fr_exit   :: a            -> Maybe (g middle last)
+data ForwardRewrites middle last a = ForwardRewrites
+    { fr_first  :: a -> BlockId -> Maybe (AGraph middle last)
+    , fr_middle :: a -> middle  -> Maybe (AGraph middle last)
+    , fr_last   :: a -> last    -> Maybe (AGraph middle last)
+    , fr_exit   :: a            -> Maybe (AGraph middle last)

     } 
 
 {- ===================== FIXED POINTS =================== -}
     } 
 
 {- ===================== FIXED POINTS =================== -}

@@ -295,15 +295,14 @@ instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint
 -- that it doesn't make us sick to look at the types.
 
 class DataflowSolverDirection transfers fixedpt =>
 -- that it doesn't make us sick to look at the types.
 
 class DataflowSolverDirection transfers fixedpt =>

-      DataflowDirection transfers fixedpt rewrites 
-                       (graph :: * -> * -> *) where
+      DataflowDirection transfers fixedpt rewrites where

   zdfRewriteFrom :: (DebugNodes m l, Outputable a)
                  => RewritingDepth      -- whether to rewrite a rewritten graph
                  -> BlockEnv a          -- initial facts (unbound == botton)
                  -> PassName
                  -> DataflowLattice a
                  -> transfers m l a
   zdfRewriteFrom :: (DebugNodes m l, Outputable a)
                  => RewritingDepth      -- whether to rewrite a rewritten graph
                  -> BlockEnv a          -- initial facts (unbound == botton)
                  -> PassName
                  -> DataflowLattice a
                  -> transfers m l a

-                 -> rewrites m l a graph
+                 -> rewrites m l a

                  -> a                   -- fact flowing in (at entry or exit)
                  -> Graph m l
                  -> FuelMonad (fixedpt m l a (Graph m l))
                  -> a                   -- fact flowing in (at entry or exit)
                  -> Graph m l
                  -> FuelMonad (fixedpt m l a (Graph m l))

@@ -319,16 +318,10 @@ data RewritingDepth = RewriteShallow | RewriteDeep
 --     forward, backward (instantiates transfers, fixedpt, rewrites)
 --     Graph, AGraph     (instantiates graph)
 
 --     forward, backward (instantiates transfers, fixedpt, rewrites)
 --     Graph, AGraph     (instantiates graph)
 

-instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites Graph
-  where zdfRewriteFrom = rewrite_f_graph
-
-instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites AGraph
+instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites

   where zdfRewriteFrom = rewrite_f_agraph
 
   where zdfRewriteFrom = rewrite_f_agraph
 

-instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites Graph
-  where zdfRewriteFrom = rewrite_b_graph
-
-instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites AGraph
+instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites

   where zdfRewriteFrom = rewrite_b_agraph
 
 
   where zdfRewriteFrom = rewrite_b_agraph
 
 

@@ -349,38 +342,20 @@ solve_f         :: (DebugNodes m l, Outputable a)
 solve_f env name lattice transfers in_fact g =
    runDFM lattice $ fwd_pure_anal name env transfers in_fact g
     
 solve_f env name lattice transfers in_fact g =
    runDFM lattice $ fwd_pure_anal name env transfers in_fact g
     

-rewrite_f_graph  :: (DebugNodes m l, Outputable a)
-                 => RewritingDepth
-                 -> BlockEnv a
-                 -> PassName
-                 -> DataflowLattice a
-                 -> ForwardTransfers m l a
-                 -> ForwardRewrites m l a Graph
-                 -> a                 -- fact flowing in (at entry or exit)
-                 -> Graph m l
-                 -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
-rewrite_f_graph depth start_facts name lattice transfers rewrites in_fact g =
-    runDFM lattice $
-    do fuel <- fuelRemaining
-       (fp, fuel') <- forward_rew maybeRewriteWithFuel return depth start_facts name
-                      transfers rewrites in_fact g fuel
-       fuelDecrement name fuel fuel'
-       return fp
-

 rewrite_f_agraph :: (DebugNodes m l, Outputable a)
                  => RewritingDepth
                  -> BlockEnv a
                  -> PassName
                  -> DataflowLattice a
                  -> ForwardTransfers m l a
 rewrite_f_agraph :: (DebugNodes m l, Outputable a)
                  => RewritingDepth
                  -> BlockEnv a
                  -> PassName
                  -> DataflowLattice a
                  -> ForwardTransfers m l a

-                 -> ForwardRewrites m l a AGraph
+                 -> ForwardRewrites  m l a

                  -> a                 -- fact flowing in (at entry or exit)
                  -> Graph m l
                  -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
 rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g =
     runDFM lattice $
     do fuel <- fuelRemaining
                  -> a                 -- fact flowing in (at entry or exit)
                  -> Graph m l
                  -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
 rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g =
     runDFM lattice $
     do fuel <- fuelRemaining

-       (fp, fuel') <- forward_rew maybeRewriteWithFuel areturn depth start_facts name
+       (fp, fuel') <- forward_rew maybeRewriteWithFuel depth start_facts name

                       transfers rewrites in_fact g fuel
        fuelDecrement name fuel fuel'
        return fp
                       transfers rewrites in_fact g fuel
        fuelDecrement name fuel fuel'
        return fp

@@ -424,10 +399,9 @@ fwd_pure_anal name env transfers in_fact g =
     do (fp, _) <- anal_f name env transfers panic_rewrites in_fact g panic_fuel
        return fp
   where -- definitiely a case of "I love lazy evaluation"
     do (fp, _) <- anal_f name env transfers panic_rewrites in_fact g panic_fuel
        return fp
   where -- definitiely a case of "I love lazy evaluation"

-    anal_f = forward_sol (\_ _ -> Nothing) panic_return panic_depth
+    anal_f = forward_sol (\_ _ -> Nothing) panic_depth

     panic_rewrites = panic "pure analysis asked for a rewrite function"
     panic_fuel     = panic "pure analysis asked for fuel"
     panic_rewrites = panic "pure analysis asked for a rewrite function"
     panic_fuel     = panic "pure analysis asked for fuel"

-    panic_return   = panic "pure analysis tried to return a rewritten graph"

     panic_depth    = panic "pure analysis asked for a rewrite depth"
 
 -----------------------------------------------------------------------
     panic_depth    = panic "pure analysis asked for a rewrite depth"
 
 -----------------------------------------------------------------------

@@ -463,32 +437,29 @@ type Fuel = OptimizationFuel
 
 {-# INLINE forward_sol #-}
 forward_sol
 
 {-# INLINE forward_sol #-}
 forward_sol

-        :: forall m l g a . 
+        :: forall m l a . 

            (DebugNodes m l, LastNode l, Outputable a)
         => (forall a . Fuel -> Maybe a -> Maybe a)
                -- Squashes proposed rewrites if there is
                -- no more fuel; OR if we are doing a pure
                -- analysis, so totally ignore the rewrite
                -- ie. For pure-analysis the fn is (\_ _ -> Nothing)
            (DebugNodes m l, LastNode l, Outputable a)
         => (forall a . Fuel -> Maybe a -> Maybe a)
                -- Squashes proposed rewrites if there is
                -- no more fuel; OR if we are doing a pure
                -- analysis, so totally ignore the rewrite
                -- ie. For pure-analysis the fn is (\_ _ -> Nothing)

-        -> (g m l -> DFM a (Graph m l))  
-               -- Transforms the kind of graph 'g' wanted by the
-               -- client (in ForwardRewrites) to the kind forward_sol likes

         -> RewritingDepth      -- Shallow/deep
         -> PassName
         -> BlockEnv a          -- Initial set of facts
         -> ForwardTransfers m l a
         -> RewritingDepth      -- Shallow/deep
         -> PassName
         -> BlockEnv a          -- Initial set of facts
         -> ForwardTransfers m l a

-        -> ForwardRewrites m l a g
+        -> ForwardRewrites m l a

         -> a                   -- Entry fact
         -> Graph m l
         -> Fuel
         -> DFM a (ForwardFixedPoint m l a (), Fuel)
         -> a                   -- Entry fact
         -> Graph m l
         -> Fuel
         -> DFM a (ForwardFixedPoint m l a (), Fuel)

-forward_sol check_maybe return_graph = forw
+forward_sol check_maybe = forw

  where
   forw :: RewritingDepth
        -> PassName
        -> BlockEnv a
        -> ForwardTransfers m l a
  where
   forw :: RewritingDepth
        -> PassName
        -> BlockEnv a
        -> ForwardTransfers m l a

-       -> ForwardRewrites m l a g
+       -> ForwardRewrites m l a

        -> a
        -> Graph m l
        -> Fuel
        -> a
        -> Graph m l
        -> Fuel

@@ -508,7 +479,7 @@ forward_sol check_maybe return_graph = forw
                       case check_maybe fuel $ fr_first rewrites idfact id of
                         Nothing -> solve_tail (ft_first_out transfers idfact id) tail fuel
                         Just g ->
                       case check_maybe fuel $ fr_first rewrites idfact id of
                         Nothing -> solve_tail (ft_first_out transfers idfact id) tail fuel
                         Just g ->

-                          do g <- return_graph g
+                          do g <- areturn g

                              (a, fuel) <- subAnalysis' $
                                case rewrite of
                                  RewriteDeep -> solve getExitFact idfact g (oneLessFuel fuel)
                              (a, fuel) <- subAnalysis' $
                                case rewrite of
                                  RewriteDeep -> solve getExitFact idfact g (oneLessFuel fuel)

@@ -530,7 +501,7 @@ forward_sol check_maybe return_graph = forw
          case check_maybe fuel $ fr_middle rewrites in' m of
            Nothing -> solve_tail (ft_middle_out transfers in' m) t fuel
            Just g ->
          case check_maybe fuel $ fr_middle rewrites in' m of
            Nothing -> solve_tail (ft_middle_out transfers in' m) t fuel
            Just g ->

-             do { g <- return_graph g
+             do { g <- areturn g

                 ; (a, fuel) <- subAnalysis' $
                      case rewrite of
                        RewriteDeep -> solve getExitFact in' g (oneLessFuel fuel)
                 ; (a, fuel) <- subAnalysis' $
                      case rewrite of
                        RewriteDeep -> solve getExitFact in' g (oneLessFuel fuel)

@@ -545,7 +516,7 @@ forward_sol check_maybe return_graph = forw
                          LastExit -> do { setExitFact (ft_exit_out transfers in')
                                         ; return (LastOutFacts [], fuel) }
            Just g ->
                          LastExit -> do { setExitFact (ft_exit_out transfers in')
                                         ; return (LastOutFacts [], fuel) }
            Just g ->

-             do { g <- return_graph g
+             do { g <- areturn g

                 ; (last_outs :: LastOutFacts a, fuel) <- subAnalysis' $
                     case rewrite of
                       RewriteDeep -> solve lastOutFacts in' g (oneLessFuel fuel)
                 ; (last_outs :: LastOutFacts a, fuel) <- subAnalysis' $
                     case rewrite of
                       RewriteDeep -> solve lastOutFacts in' g (oneLessFuel fuel)

@@ -583,27 +554,26 @@ mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l
 
 {-# INLINE forward_rew #-}
 forward_rew
 
 {-# INLINE forward_rew #-}
 forward_rew

-        :: forall m l g a . 
+        :: forall m l a . 

            (DebugNodes m l, LastNode l, Outputable a)
         => (forall a . Fuel -> Maybe a -> Maybe a)
            (DebugNodes m l, LastNode l, Outputable a)
         => (forall a . Fuel -> Maybe a -> Maybe a)

-        -> (g m l -> DFM a (Graph m l))  -- option on what to rewrite

         -> RewritingDepth
         -> BlockEnv a
         -> PassName
         -> ForwardTransfers m l a
         -> RewritingDepth
         -> BlockEnv a
         -> PassName
         -> ForwardTransfers m l a

-        -> ForwardRewrites m l a g
+        -> ForwardRewrites m l a

         -> a
         -> Graph m l
         -> Fuel
         -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
         -> a
         -> Graph m l
         -> Fuel
         -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)

-forward_rew check_maybe return_graph = forw
+forward_rew check_maybe = forw

   where
   where

-    solve = forward_sol check_maybe return_graph
+    solve = forward_sol check_maybe

     forw :: RewritingDepth
          -> BlockEnv a
          -> PassName
          -> ForwardTransfers m l a
     forw :: RewritingDepth
          -> BlockEnv a
          -> PassName
          -> ForwardTransfers m l a

-         -> ForwardRewrites m l a g
+         -> ForwardRewrites m l a

          -> a
          -> Graph m l
          -> Fuel
          -> a
          -> Graph m l
          -> Fuel

@@ -653,7 +623,7 @@ forward_rew check_maybe return_graph = forw
                                              t rewritten fuel
                                ; rewrite_blocks bs rewritten fuel }
                  Just g  -> do { markGraphRewritten
                                              t rewritten fuel
                                ; rewrite_blocks bs rewritten fuel }
                  Just g  -> do { markGraphRewritten

-                               ; g <- return_graph g
+                               ; g <- areturn g

                                ; (outfact, g, fuel) <- inner_rew getExitFact a g fuel
                                ; let (blocks, h) = splice_head' (ZFirst id) g
                                ; (rewritten, fuel) <-
                                ; (outfact, g, fuel) <- inner_rew getExitFact a g fuel
                                ; let (blocks, h) = splice_head' (ZFirst id) g
                                ; (rewritten, fuel) <-

@@ -666,7 +636,7 @@ forward_rew check_maybe return_graph = forw
               Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers in' m) t
                          rewritten fuel
               Just g -> do { markGraphRewritten
               Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers in' m) t
                          rewritten fuel
               Just g -> do { markGraphRewritten

-                           ; g <- return_graph g
+                           ; g <- areturn g

                            ; (a, g, fuel) <- inner_rew getExitFact in' g fuel
                            ; let (blocks, h) = G.splice_head' head g
                            ; rew_tail h a t (blocks `plusUFM` rewritten) fuel
                            ; (a, g, fuel) <- inner_rew getExitFact in' g fuel
                            ; let (blocks, h) = G.splice_head' head g
                            ; rew_tail h a t (blocks `plusUFM` rewritten) fuel

@@ -677,7 +647,7 @@ forward_rew check_maybe return_graph = forw
               Nothing -> do check_facts in' l
                             return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
               Just g -> do { markGraphRewritten
               Nothing -> do check_facts in' l
                             return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
               Just g -> do { markGraphRewritten

-                           ; g <- return_graph g
+                           ; g <- areturn g

                            ; ((), g, fuel) <- inner_rew (return ()) in' g fuel
                            ; let g' = G.splice_head_only' h g
                            ; return (G.lg_blocks g' `plusUFM` rewritten, fuel)
                            ; ((), g, fuel) <- inner_rew (return ()) in' g fuel
                            ; let g' = G.splice_head_only' h g
                            ; return (G.lg_blocks g' `plusUFM` rewritten, fuel)

@@ -690,7 +660,6 @@ forward_rew check_maybe return_graph = forw
           check_facts _ LastExit = return []
       in  fixed_pt_and_fuel
 
           check_facts _ LastExit = return []
       in  fixed_pt_and_fuel
 

---lastOutFacts :: (DataflowAnalysis m, Monad (m f)) => m f (LastOutFacts f)

 lastOutFacts :: DFM f (LastOutFacts f)
 lastOutFacts = bareLastOutFacts >>= return . LastOutFacts
 
 lastOutFacts :: DFM f (LastOutFacts f)
 lastOutFacts = bareLastOutFacts >>= return . LastOutFacts
 

@@ -708,38 +677,20 @@ solve_b env name lattice transfers exit_fact g =
    runDFM lattice $ bwd_pure_anal name env transfers g exit_fact
     
 
    runDFM lattice $ bwd_pure_anal name env transfers g exit_fact
     
 

-rewrite_b_graph  :: (DebugNodes m l, Outputable a)
-                 => RewritingDepth
-                 -> BlockEnv a
-                 -> PassName
-                 -> DataflowLattice a
-                 -> BackwardTransfers m l a
-                 -> BackwardRewrites m l a Graph
-                 -> a                 -- fact flowing in at exit
-                 -> Graph m l
-                 -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
-rewrite_b_graph depth start_facts name lattice transfers rewrites exit_fact g =
-    runDFM lattice $
-    do fuel <- fuelRemaining
-       (fp, fuel') <- backward_rew maybeRewriteWithFuel return depth start_facts name
-                      transfers rewrites g exit_fact fuel
-       fuelDecrement name fuel fuel'
-       return fp
-

 rewrite_b_agraph :: (DebugNodes m l, Outputable a)
                  => RewritingDepth
                  -> BlockEnv a
                  -> PassName
                  -> DataflowLattice a
                  -> BackwardTransfers m l a
 rewrite_b_agraph :: (DebugNodes m l, Outputable a)
                  => RewritingDepth
                  -> BlockEnv a
                  -> PassName
                  -> DataflowLattice a
                  -> BackwardTransfers m l a

-                 -> BackwardRewrites m l a AGraph
+                 -> BackwardRewrites m l a

                  -> a                 -- fact flowing in at exit
                  -> Graph m l
                  -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
 rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g =
     runDFM lattice $
     do fuel <- fuelRemaining
                  -> a                 -- fact flowing in at exit
                  -> Graph m l
                  -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
 rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g =
     runDFM lattice $
     do fuel <- fuelRemaining

-       (fp, fuel') <- backward_rew maybeRewriteWithFuel areturn depth start_facts name
+       (fp, fuel') <- backward_rew maybeRewriteWithFuel depth start_facts name

                       transfers rewrites g exit_fact fuel
        fuelDecrement name fuel fuel'
        return fp
                       transfers rewrites g exit_fact fuel
        fuelDecrement name fuel fuel'
        return fp

@@ -748,26 +699,25 @@ rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g =
 
 {-# INLINE backward_sol #-}
 backward_sol
 
 {-# INLINE backward_sol #-}
 backward_sol

-        :: forall m l g a . 
+        :: forall m l a . 

            (DebugNodes m l, LastNode l, Outputable a)
         => (forall a . Fuel -> Maybe a -> Maybe a)
            (DebugNodes m l, LastNode l, Outputable a)
         => (forall a . Fuel -> Maybe a -> Maybe a)

-        -> (g m l -> DFM a (Graph m l))  -- option on what to rewrite

         -> RewritingDepth
         -> PassName
         -> BlockEnv a
         -> BackwardTransfers m l a
         -> RewritingDepth
         -> PassName
         -> BlockEnv a
         -> BackwardTransfers m l a

-        -> BackwardRewrites m l a g
+        -> BackwardRewrites m l a

         -> Graph m l
         -> a
         -> Fuel
         -> DFM a (BackwardFixedPoint m l a (), Fuel)
         -> Graph m l
         -> a
         -> Fuel
         -> DFM a (BackwardFixedPoint m l a (), Fuel)

-backward_sol check_maybe return_graph = back
+backward_sol check_maybe = back

  where
   back :: RewritingDepth
        -> PassName
        -> BlockEnv a
        -> BackwardTransfers m l a
  where
   back :: RewritingDepth
        -> PassName
        -> BlockEnv a
        -> BackwardTransfers m l a

-       -> BackwardRewrites m l a g
+       -> BackwardRewrites m l a

        -> Graph m l
        -> a
        -> Fuel
        -> Graph m l
        -> a
        -> Fuel

@@ -778,13 +728,13 @@ backward_sol check_maybe return_graph = back
            do { fp <- bwd_pure_anal name emptyBlockEnv transfers g out
               ; return $ zdfFpOutputFact fp }
 
            do { fp <- bwd_pure_anal name emptyBlockEnv transfers g out
               ; return $ zdfFpOutputFact fp }
 

-       subsolve :: g m l -> a -> Fuel -> DFM a (a, Fuel)
+       subsolve :: AGraph m l -> a -> Fuel -> DFM a (a, Fuel)

        subsolve =
          case rewrite of
            RewriteDeep    -> \g a fuel ->
        subsolve =
          case rewrite of
            RewriteDeep    -> \g a fuel ->

-               subAnalysis' $ do { g <- return_graph g; solve g a (oneLessFuel fuel) }
+               subAnalysis' $ do { g <- areturn g; solve g a (oneLessFuel fuel) }

            RewriteShallow -> \g a fuel ->
            RewriteShallow -> \g a fuel ->

-               subAnalysis' $ do { g <- return_graph g; a <- anal_b g a
+               subAnalysis' $ do { g <- areturn g; a <- anal_b g a

                                  ; return (a, oneLessFuel fuel) }
 
        solve :: Graph m l -> a -> Fuel -> DFM a (a, Fuel)
                                  ; return (a, oneLessFuel fuel) }
 
        solve :: Graph m l -> a -> Fuel -> DFM a (a, Fuel)

@@ -848,10 +798,9 @@ bwd_pure_anal name env transfers g exit_fact =
     do (fp, _) <- anal_b name env transfers panic_rewrites g exit_fact panic_fuel
        return fp
   where -- another case of "I love lazy evaluation"
     do (fp, _) <- anal_b name env transfers panic_rewrites g exit_fact panic_fuel
        return fp
   where -- another case of "I love lazy evaluation"

-    anal_b = backward_sol (\_ _ -> Nothing) panic_return panic_depth
+    anal_b = backward_sol (\_ _ -> Nothing) panic_depth

     panic_rewrites = panic "pure analysis asked for a rewrite function"
     panic_fuel     = panic "pure analysis asked for fuel"
     panic_rewrites = panic "pure analysis asked for a rewrite function"
     panic_fuel     = panic "pure analysis asked for fuel"

-    panic_return   = panic "pure analysis tried to return a rewritten graph"

     panic_depth    = panic "pure analysis asked for a rewrite depth"
 
 
     panic_depth    = panic "pure analysis asked for a rewrite depth"
 
 

@@ -859,27 +808,26 @@ bwd_pure_anal name env transfers g exit_fact =
 
 {-# INLINE backward_rew #-}
 backward_rew
 
 {-# INLINE backward_rew #-}
 backward_rew

-        :: forall m l g a . 
+        :: forall m l a . 

            (DebugNodes m l, LastNode l, Outputable a)
         => (forall a . Fuel -> Maybe a -> Maybe a)
            (DebugNodes m l, LastNode l, Outputable a)
         => (forall a . Fuel -> Maybe a -> Maybe a)

-        -> (g m l -> DFM a (Graph m l))  -- option on what to rewrite

         -> RewritingDepth
         -> BlockEnv a
         -> PassName
         -> BackwardTransfers m l a
         -> RewritingDepth
         -> BlockEnv a
         -> PassName
         -> BackwardTransfers m l a

-        -> BackwardRewrites m l a g
+        -> BackwardRewrites m l a

         -> Graph m l
         -> a
         -> Fuel
         -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
         -> Graph m l
         -> a
         -> Fuel
         -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)

-backward_rew check_maybe return_graph = back
+backward_rew check_maybe = back

   where
   where

-    solve = backward_sol check_maybe return_graph
+    solve = backward_sol check_maybe

     back :: RewritingDepth
          -> BlockEnv a
          -> PassName
          -> BackwardTransfers m l a
     back :: RewritingDepth
          -> BlockEnv a
          -> PassName
          -> BackwardTransfers m l a

-         -> BackwardRewrites m l a g
+         -> BackwardRewrites m l a

          -> Graph m l
          -> a
          -> Fuel
          -> Graph m l
          -> a
          -> Fuel

@@ -930,7 +878,7 @@ backward_rew check_maybe return_graph = back
               Nothing -> propagate check fuel h (last_in env l) (ZLast l) rewritten
               Just g ->
                 do { markGraphRewritten
               Nothing -> propagate check fuel h (last_in env l) (ZLast l) rewritten
               Just g ->
                 do { markGraphRewritten

-                   ; g <- return_graph g
+                   ; g <- areturn g

                    ; (a, g, fuel) <- inner_rew g exit_fact fuel
                    ; let G.Graph t new_blocks = g
                    ; let rewritten' = new_blocks `plusUFM` rewritten
                    ; (a, g, fuel) <- inner_rew g exit_fact fuel
                    ; let G.Graph t new_blocks = g
                    ; let rewritten' = new_blocks `plusUFM` rewritten

@@ -946,7 +894,7 @@ backward_rew check_maybe return_graph = back
                 propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten
               Just g  ->
                 do { markGraphRewritten
                 propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten
               Just g  ->
                 do { markGraphRewritten

-                   ; g <- return_graph g
+                   ; g <- areturn g

                    ; my_trace "With Facts" (ppr a) $ return ()
                    ; my_trace "  Rewrote middle node"
                                              (f4sep [ppr m, text "to", pprGraph g]) $
                    ; my_trace "With Facts" (ppr a) $ return ()
                    ; my_trace "  Rewrote middle node"
                                              (f4sep [ppr m, text "to", pprGraph g]) $

@@ -961,7 +909,7 @@ backward_rew check_maybe return_graph = back
                             ; return (insertBlock (Block id tail) rewritten, fuel) }
               Just g ->
                 do { markGraphRewritten
                             ; return (insertBlock (Block id tail) rewritten, fuel) }
               Just g ->
                 do { markGraphRewritten

-                   ; g <- return_graph g
+                   ; g <- areturn g

                    ; my_trace "Rewrote first node"
                      (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
                    ; (a, g, fuel) <- inner_rew g a fuel
                    ; my_trace "Rewrote first node"
                      (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
                    ; (a, g, fuel) <- inner_rew g a fuel

diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index 6a26e66..51c07b2 100644 (file)
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -70,6 +70,7 @@ import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
 
 import DynFlags
 import PackageConfig
 
 import DynFlags
 import PackageConfig

+import BlockId

 import Cmm
 import CmmUtils
 import CLabel
 import Cmm
 import CmmUtils
 import CLabel

diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 1f44c43..ee8e335 100644 (file)
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -53,6 +53,7 @@ module CgUtils (
 #include "HsVersions.h"
 #include "../includes/MachRegs.h"
 
 #include "HsVersions.h"
 #include "../includes/MachRegs.h"
 

+import BlockId

 import CgMonad
 import TyCon
 import DataCon
 import CgMonad
 import TyCon
 import DataCon

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 152381c..ab4ab01 100644 (file)
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -73,6 +73,12 @@ readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
           = printer (text what <> text ": " <>
                      vcat [text "Wanted " <> ppr wanted <> text ",",
                            text "got    " <> ppr got])
           = printer (text what <> text ": " <>
                      vcat [text "Wanted " <> ppr wanted <> text ",",
                            text "got    " <> ppr got])

+
+      errorOnMismatch' :: (Eq a, Show a) => String -> a -> a -> IO () -> IO ()
+      errorOnMismatch' what wanted got io
+           = do when (wanted /= got) $ io
+                errorOnMismatch what wanted got
+

       errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
       errorOnMismatch what wanted got
             -- This will be caught by readIface which will emit an error
       errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
       errorOnMismatch what wanted got
             -- This will be caught by readIface which will emit an error

diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs
index 81e3bec..3a446c0 100644 (file)
--- a/compiler/nativeGen/MachCodeGen.hs
+++ b/compiler/nativeGen/MachCodeGen.hs
@@ -32,6 +32,7 @@ import PositionIndependentCode
 import RegAllocInfo ( mkBranchInstr )
 
 -- Our intermediate code:
 import RegAllocInfo ( mkBranchInstr )
 
 -- Our intermediate code:

+import BlockId

 import PprCmm          ( pprExpr )
 import Cmm
 import MachOp
 import PprCmm          ( pprExpr )
 import Cmm
 import MachOp

diff --git a/compiler/nativeGen/MachInstrs.hs b/compiler/nativeGen/MachInstrs.hs
index 716a521..00317ee 100644 (file)
--- a/compiler/nativeGen/MachInstrs.hs
+++ b/compiler/nativeGen/MachInstrs.hs
@@ -43,6 +43,7 @@ module MachInstrs (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import BlockId

 import MachRegs
 import Cmm
 import MachOp          ( MachRep(..) )
 import MachRegs
 import Cmm
 import MachOp          ( MachRep(..) )

diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
index 4852af3..e5da5a5 100644 (file)
--- a/compiler/nativeGen/NCGMonad.hs
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -25,7 +25,7 @@ module NCGMonad (
   
 #include "HsVersions.h"
 
   
 #include "HsVersions.h"
 

-import Cmm             ( BlockId(..) )
+import BlockId

 import CLabel          ( CLabel, mkAsmTempLabel )
 import MachRegs
 import MachOp          ( MachRep )
 import CLabel          ( CLabel, mkAsmTempLabel )
 import MachRegs
 import MachOp          ( MachRep )

diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs
index 1995cd0..0c14ff8 100644 (file)
--- a/compiler/nativeGen/PprMach.hs
+++ b/compiler/nativeGen/PprMach.hs
@@ -26,6 +26,7 @@ module PprMach (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import BlockId

 import Cmm
 import MachOp          ( MachRep(..), wordRep, isFloatingRep )
 import MachRegs                -- may differ per-platform
 import Cmm
 import MachOp          ( MachRep(..), wordRep, isFloatingRep )
 import MachRegs                -- may differ per-platform

diff --git a/compiler/nativeGen/RegAllocInfo.hs b/compiler/nativeGen/RegAllocInfo.hs
index da876c3..0328b95 100644 (file)
--- a/compiler/nativeGen/RegAllocInfo.hs
+++ b/compiler/nativeGen/RegAllocInfo.hs
@@ -35,6 +35,7 @@ module RegAllocInfo (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import BlockId

 import Cmm
 import CLabel
 import MachOp           ( MachRep(..), wordRep )
 import Cmm
 import CLabel
 import MachOp           ( MachRep(..), wordRep )

diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs
index 9478979..de6e664 100644 (file)
--- a/compiler/nativeGen/RegAllocLinear.hs
+++ b/compiler/nativeGen/RegAllocLinear.hs
@@ -88,6 +88,7 @@ module RegAllocLinear (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import BlockId

 import MachRegs
 import MachInstrs
 import RegAllocInfo
 import MachRegs
 import MachInstrs
 import RegAllocInfo

diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 50af2eb..dce5de4 100644 (file)
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -30,6 +30,7 @@ module RegLiveness (
 
   ) where
 
 
   ) where
 

+import BlockId

 import MachRegs
 import MachInstrs
 import PprMach
 import MachRegs
 import MachInstrs
 import PprMach

diff --git a/compiler/nativeGen/RegSpillClean.hs b/compiler/nativeGen/RegSpillClean.hs
index 8cfeb18..eb0e3ea 100644 (file)
--- a/compiler/nativeGen/RegSpillClean.hs
+++ b/compiler/nativeGen/RegSpillClean.hs
@@ -29,6 +29,7 @@ module RegSpillClean (
 )
 where
 
 )
 where
 

+import BlockId

 import RegLiveness
 import RegAllocInfo
 import MachRegs
 import RegLiveness
 import RegAllocInfo
 import MachRegs