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)

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

compiler/cmm/Cmm.hs

@@ -23,14 +23,11 @@ module Cmm (
 	CmmCallTarget(..),
 	CmmStatic(..), Section(..),
         module CmmExpr,
-
-        BlockId(..), mkBlockId,
-        BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv,
-        BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet,
   ) where
 
 #include "HsVersions.h"
 
+import BlockId
 import CmmExpr
 import MachOp
 import CLabel
@@ -42,10 +39,6 @@ import FastString
 
 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
@@ -277,7 +270,6 @@ instance UserOfLocalRegs CmmCallTarget where
 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

compiler/cmm/CmmBrokenBlock.hs

@@ -20,6 +20,7 @@ module CmmBrokenBlock (
 
 #include "HsVersions.h"
 
+import BlockId
 import Cmm
 import CmmUtils
 import CLabel

compiler/cmm/CmmCPS.hs

@@ -13,6 +13,7 @@ module CmmCPS (
 
 #include "HsVersions.h"
 
+import BlockId
 import Cmm
 import CmmLint
 import PprCmm

compiler/cmm/CmmCPSGen.hs

@@ -13,6 +13,7 @@ module CmmCPSGen (
   ContinuationFormat(..),
 ) where
 
+import BlockId
 import Cmm
 import CLabel
 import CmmBrokenBlock -- Data types only

compiler/cmm/CmmCPSZ.hs

@@ -5,6 +5,7 @@ module CmmCPSZ (
   protoCmmCPSZ
 ) where
 
+import BlockId
 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
-       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"
-                             (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
@@ -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 >>= 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

compiler/cmm/CmmCommonBlockElimZ.hs

@@ -4,6 +4,7 @@ module CmmCommonBlockElimZ
 where
 
 
+import BlockId
 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_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_e (CmmStackSlot _ _) = 13
         hash_lit (CmmInt i _) = fromInteger i
         hash_lit (CmmFloat r _) = truncate r
         hash_lit (CmmLabel _) = 119 -- ugh

compiler/cmm/CmmContFlowOpt.hs

@@ -6,10 +6,10 @@ module CmmContFlowOpt
     )
 where
 
+import BlockId
 import Cmm
 import CmmTx
 import qualified ZipCfg as G
-import StackSlot
 import ZipCfgCmmRep
 
 import Maybes

compiler/cmm/CmmCvt.hs

@@ -4,6 +4,7 @@ module CmmCvt
   ( cmmToZgraph, cmmOfZgraph )
 where
 
+import BlockId
 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)) = 
-           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 
@@ -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 (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"
+        -- 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

compiler/cmm/CmmExpr.hs

@@ -8,19 +8,18 @@ module CmmExpr
     , 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 Maybes
 import Monad
 import Panic
-import StackSlot
 import Unique
 import UniqSet
-import UniqSupply
 
 -----------------------------------------------------------------------------
 --		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
+  | CmmStackSlot Area Int
   deriving Eq
 
 data CmmReg 
   = CmmLocal  LocalReg
   | CmmGlobal GlobalReg
-  | CmmStack  StackSlot
   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
@@ -119,19 +125,35 @@ timesRegSet      = intersectUniqSets
 --    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.
-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
-                  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
-    foldRegsUsed _ z (CmmStack _)  = 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
@@ -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 (CmmStackSlot _ _)  = z
 
 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 (CmmStackSlot _ _) = wordRep
 
 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

compiler/cmm/CmmLint.hs

@@ -16,6 +16,7 @@ module CmmLint (
   cmmLint, cmmLintTop
   ) where
 
+import BlockId
 import Cmm
 import CLabel
 import MachOp

compiler/cmm/CmmLive.hs

@@ -14,6 +14,7 @@ module CmmLive (
 
 #include "HsVersions.h"
 
+import BlockId
 import Cmm
 import Dataflow
 

compiler/cmm/CmmLiveZ.hs

@@ -7,13 +7,13 @@ module CmmLiveZ
     ) 
 where
 
+import BlockId
 import CmmExpr
 import CmmTx
 import DFMonad
 import Monad
 import PprCmm()
 import PprCmmZ()
-import StackSlot
 import ZipCfg
 import ZipDataflow
 import ZipCfgCmmRep