Commit 0d80489c authored by dias@eecs.harvard.edu's avatar dias@eecs.harvard.edu

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)
parent 724a9e83
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.
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 Monad
import Outputable
import Unique
import UniqFM
import Unique
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
......@@ -94,4 +58,3 @@ mkBlockSet :: [BlockId] -> BlockSet
mkBlockSet = mkUniqSet
sizeBlockSet :: BlockSet -> Int
sizeBlockSet = sizeUniqSet
......@@ -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
......
......@@ -20,6 +20,7 @@ module CmmBrokenBlock (
#include "HsVersions.h"
import BlockId
import Cmm
import CmmUtils
import CLabel
......
......@@ -13,6 +13,7 @@ module CmmCPS (
#include "HsVersions.h"
import BlockId
import Cmm
import CmmLint
import PprCmm
......
......@@ -13,6 +13,7 @@ module CmmCPSGen (
ContinuationFormat(..),
) where
import BlockId
import Cmm
import CLabel
import CmmBrokenBlock -- Data types only
......
......@@ -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
......
......@@ -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
......
......@@ -6,10 +6,10 @@ module CmmContFlowOpt
)
where
import BlockId
import Cmm
import CmmTx
import qualified ZipCfg as G
import StackSlot
import ZipCfgCmmRep
import Maybes
......
......@@ -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
......
......@@ -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
......
......@@ -16,6 +16,7 @@ module CmmLint (
cmmLint, cmmLintTop
) where
import BlockId
import Cmm
import CLabel
import MachOp
......
......@@ -14,6 +14,7 @@ module CmmLive (
#include "HsVersions.h"
import BlockId
import Cmm
import Dataflow
......
......@@ -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
......
......@@ -11,6 +11,7 @@ module CmmProcPoint (
#include "HsVersions.h"
import BlockId
import Cmm
import CmmBrokenBlock
import Dataflow
......
......@@ -8,6 +8,7 @@ where
import Prelude hiding (zip, unzip, last)
import BlockId
import CLabel
--import ClosureInfo
import Cmm hiding (blockId)
......@@ -17,7 +18,6 @@ import CmmLiveZ
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)
......@@ -25,7 +25,6 @@ import Monad
import Name
import Outputable
import Panic
import StackSlot
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
......@@ -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.
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'
......@@ -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 (Block id _) env | id == lg_entry g =
extendBlockEnv env id (Protocol stdArgConvention hfs $ toArea id hfs)
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
......@@ -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 $
mkStackArea id formals $ Just formals
mkCallArea id formals $ Just formals
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)
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
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))
......@@ -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
skip b@(Block bid _) bs = bs >>= (\bmap -> return $ extendBlockEnv bmap bid b)
-- Input invariant: A block should only be reachable from a single ProcPoint.
......
......@@ -15,6 +15,7 @@ module CmmSpillReload
)
where
import BlockId
import CmmExpr
import CmmTx
import CmmLiveZ
......@@ -22,7 +23,6 @@ import DFMonad
import MkZipCfg
import OptimizationFuel
import PprCmm()
import StackSlot
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
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
Just $ graphOfMiddles $ [Reload reloads]
Just $ mkMiddles $ [Reload reloads]
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
......@@ -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]) $
Just $ graphOfMiddles [m, Spill $ mkRegSet [reg]]
Just $ mkMiddles [m, Spill $ mkRegSet [reg]]
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]) $
Just $ graphOfMiddles (m : code')
Just $ mkMiddles (m : code')
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
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
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 =
......@@ -356,18 +351,18 @@ removeDeadAssignmentsAndReloads procPoints g =
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
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') _)
| not (reg' `elemRegSet` in_regs live) = Just emptyGraph
| not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
middle _ = Nothing
......
......@@ -4,8 +4,8 @@ module CmmZipUtil
, givesUniquePredecessorTo
)
where
import BlockId
import Prelude hiding (last, unzip)
import StackSlot
import ZipCfg
import Maybes
......
......@@ -12,10 +12,10 @@ module DFMonad
)
where
import BlockId
import CmmTx
import PprCmm()
import OptimizationFuel
import StackSlot
import Control.Monad
import Maybes
......
......@@ -9,7 +9,7 @@ module MkZipCfg
)
where
import StackSlot
import BlockId (BlockId(..), emptyBlockEnv)
import ZipCfg
import Outputable
......
......@@ -19,16 +19,16 @@ where
#include "HsVersions.h"
import BlockId
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 StackSlot
import ClosureInfo
import FastString
......@@ -62,10 +62,10 @@ mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
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