Commit 8b7eaa40 authored by nr@eecs.harvard.edu's avatar nr@eecs.harvard.edu

adding new files to do with new cmm functionality

parent bd50bd07
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module CmmCPSZ (
-- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest.
-- Well, sort of.
protoCmmCPSZ
) where
import Cmm
import CmmContFlowOpt
import CmmProcPointZ
import CmmSpillReload
import CmmTx
import DFMonad
import DynFlags
import ErrUtils
import Outputable
import PprCmmZ()
import UniqSupply
import ZipCfg hiding (zip, unzip)
import ZipCfgCmm
import ZipDataflow
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
protoCmmCPSZ :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
-> CmmZ -- ^ Input C-- with Proceedures
-> IO CmmZ -- ^ Output CPS transformed C--
protoCmmCPSZ dflags (Cmm tops)
= do { showPass dflags "CPSZ"
; u <- mkSplitUniqSupply 'p'
; let txtops = initUs_ u $ mapM cpsTop tops
; let pgm = Cmm $ runDFTx maxBound $ sequence txtops
--- XXX calling runDFTx is totally bogus
; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (ppr pgm)
; return pgm
}
cpsTop :: CmmTopZ -> UniqSM (DFTx CmmTopZ)
cpsTop p@(CmmData {}) = return $ return p
cpsTop (CmmProc h l args g) =
let procPoints = minimalProcPointSet (runTx cmmCfgOptsZ g)
g' = addProcPointProtocols procPoints args g
g'' = map_nodes id NotSpillOrReload id g'
in do us <- getUs
let g = runDFM us dualLiveLattice $ b_rewrite dualLivenessWithInsertion g''
-- let igraph = buildIGraph
return $ do g' <- g >>= return . map_nodes id spillAndReloadComments id
return $ CmmProc h l args g'
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module CmmContFlowOpt
( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ
, branchChainElimZ, removeUnreachableBlocksZ
)
where
import Cmm
import CmmTx
import qualified ZipCfg as G
import ZipCfgCmm
import Maybes
import Util
import UniqFM
------------------------------------
mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s)
mapProcs f (Cmm tops) = fmap Cmm (mapTx f tops)
------------------------------------
cmmCfgOpts :: Tx (ListGraph CmmStmt)
cmmCfgOptsZ :: Tx CmmGraph
cmmCfgOpts = branchChainElim -- boring, but will get more exciting later
cmmCfgOptsZ = branchChainElimZ `seqTx` removeUnreachableBlocksZ
-- Here branchChainElim can ultimately be replaced
-- with a more exciting combination of optimisations
runCmmOpts :: Tx g -> Tx (GenCmm d h g)
runCmmOpts opt = mapProcs (optGraph opt)
optGraph :: Tx g -> Tx (GenCmmTop d h g)
optGraph _ top@(CmmData {}) = noTx top
optGraph opt (CmmProc info lbl formals g) = fmap (CmmProc info lbl formals) (opt g)
----------------------------------------------------------------
branchChainElim :: Tx (ListGraph CmmStmt)
-- Remove any basic block of the form L: goto L',
-- and replace L with L' everywhere else
branchChainElim (ListGraph blocks)
| null lone_branch_blocks -- No blocks to remove
= noTx (ListGraph blocks)
| otherwise
= aTx (ListGraph new_blocks)
where
(lone_branch_blocks, others) = partitionWith isLoneBranch blocks
new_blocks = map (replaceLabels env) others
env = mkClosureBlockEnv lone_branch_blocks
isLoneBranch :: CmmBasicBlock -> Either (BlockId, BlockId) CmmBasicBlock
isLoneBranch (BasicBlock id [CmmBranch target]) | id /= target = Left (id, target)
isLoneBranch other_block = Right other_block
-- ^ An infinite loop is not a link in a branch chain!
replaceLabels :: BlockEnv BlockId -> CmmBasicBlock -> CmmBasicBlock
replaceLabels env (BasicBlock id stmts)
= BasicBlock id (map replace stmts)
where
replace (CmmBranch id) = CmmBranch (lookup id)
replace (CmmCondBranch e id) = CmmCondBranch e (lookup id)
replace (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
replace other_stmt = other_stmt
lookup id = lookupBlockEnv env id `orElse` id
----------------------------------------------------------------
branchChainElimZ :: Tx CmmGraph
-- Remove any basic block of the form L: goto L',
-- and replace L with L' everywhere else
branchChainElimZ g@(G.LGraph eid _)
| null lone_branch_blocks -- No blocks to remove
= noTx g
| otherwise
= aTx $ replaceLabelsZ env $ G.of_block_list eid (self_branches ++ others)
where
(lone_branch_blocks, others) = partitionWith isLoneBranchZ (G.to_block_list g)
env = mkClosureBlockEnv lone_branch_blocks
self_branches =
let loop_to (id, _) =
if lookup id == id then
Just (G.Block id (G.ZLast (G.mkBranchNode id)))
else
Nothing
in mapMaybe loop_to lone_branch_blocks
lookup id = G.lookupBlockEnv env id `orElse` id
isLoneBranchZ :: CmmBlock -> Either (G.BlockId, G.BlockId) CmmBlock
isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target []))))
| id /= target = Left (id,target)
isLoneBranchZ other = Right other
-- ^ An infinite loop is not a link in a branch chain!
replaceLabelsZ :: BlockEnv G.BlockId -> CmmGraph -> CmmGraph
replaceLabelsZ env = replace_eid . G.map_nodes id id last
where
replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks
last (LastBranch id args) = LastBranch (lookup id) args
last (LastCondBranch e ti fi) = LastCondBranch e (lookup ti) (lookup fi)
last (LastSwitch e tbl) = LastSwitch e (map (fmap lookup) tbl)
last (LastCall tgt args (Just id)) = LastCall tgt args (Just $ lookup id)
last exit_jump_return = exit_jump_return
lookup id = G.lookupBlockEnv env id `orElse` id
----------------------------------------------------------------
mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
mkClosureBlockEnv blocks = mkBlockEnv $ map follow blocks
where singleEnv = mkBlockEnv blocks
follow (id, next) = (id, endChain id next)
endChain orig id = case lookupBlockEnv singleEnv id of
Just id' | id /= orig -> endChain orig id'
_ -> id
----------------------------------------------------------------
removeUnreachableBlocksZ :: Tx CmmGraph
removeUnreachableBlocksZ g@(G.LGraph id blocks) =
if length blocks' < sizeUFM blocks then aTx $ G.of_block_list id blocks'
else noTx g
where blocks' = G.postorder_dfs g
{-# LANGUAGE PatternGuards #-}
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module CmmCvt
( cmmToZgraph, cmmOfZgraph )
where
import Cmm
import CmmExpr
import ZipCfgCmm
import MkZipCfg
import CmmZipUtil
import FastString
import Outputable
import Panic
import PprCmm()
import PprCmmZ()
import UniqSet
import UniqSupply
import qualified ZipCfg as G
cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
cmmOfZgraph :: GenCmm d h (CmmGraph) -> GenCmm d h (ListGraph CmmStmt)
cmmToZgraph = cmmMapGraphM toZgraph
cmmOfZgraph = cmmMapGraph ofZgraph
toZgraph :: String -> ListGraph CmmStmt -> UniqSM CmmGraph
toZgraph _ (ListGraph []) = lgraphOfAGraph emptyAGraph
toZgraph fun_name (ListGraph (BasicBlock id ss : other_blocks)) =
labelAGraph id $ 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 (CmmComment s : ss) = mkComment s <*> mkStmts ss
mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss
mkStmts (CmmCall f res args (CmmSafe srt) CmmMayReturn : ss) =
mkCall f res args srt <*> mkStmts ss
mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
mkUnsafeCall f res args <*> mkStmts ss
mkStmts (CmmCondBranch e l : fbranch) =
mkIfThenElse (mkCbranch e) (mkBranch l) (mkStmts fbranch)
mkStmts (last : []) = mkLast last
mkStmts [] = bad "fell off end"
mkStmts (_ : _ : _) = bad "last node not at end"
bad msg = panic (msg {- ++ " in block " ++ showSDoc (ppr b) -}
++ " in function " ++ fun_name)
mkLast (CmmCall f [] args _ CmmNeverReturns) = mkFinalCall f args
mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
mkLast (CmmJump tgt args) = mkJump tgt args
mkLast (CmmReturn ress) = mkReturn 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"
ofZgraph :: CmmGraph -> ListGraph CmmStmt
ofZgraph g = ListGraph $ swallow blocks
where blocks = G.postorder_dfs g
-- | the next two functions are hooks on which to hang debugging info
extend_entry stmts = stmts
extend_block _id stmts = stmts
_extend_entry stmts = scomment showblocks : scomment cscomm : stmts
showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
concat (map (\(G.Block id _) -> " " ++ show id) blocks)
cscomm = "Call successors are" ++
(concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
swallow [] = []
swallow (G.Block id t : rest) = tail id [] t rest
tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest
tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest
tail id prev' (G.ZLast (G.LastOther l))rest = last id prev' l rest
mid (MidNop) = CmmNop
mid (MidComment s) = CmmComment s
mid (MidAssign l r) = CmmAssign l r
mid (MidStore l r) = CmmStore l r
mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
mid m@(CopyOut {}) = pcomment (ppr m)
mid m@(CopyIn {}) = pcomment (ppr m <+> text "(proc point)")
pcomment p = scomment $ showSDoc p
block' id prev'
| id == G.gr_entry g = BasicBlock id $ extend_entry (reverse prev')
| otherwise = BasicBlock id $ extend_block id (reverse prev')
last id prev' l n =
let endblock stmt = block' id (stmt : prev') : swallow n in
case l of
LastBranch _ (_:_) -> panic "unrepresentable branch"
LastBranch tgt [] ->
case n of
G.Block id' t : bs
| tgt == id', unique_pred id'
-> tail id prev' t bs -- optimize out redundant labels
_ -> endblock (CmmBranch tgt)
LastCondBranch expr tid fid ->
case n of
G.Block id' t : bs
| id' == fid, unique_pred id' ->
tail id (CmmCondBranch expr tid : prev') t bs
| id' == tid, unique_pred id',
Just e' <- maybeInvertCmmExpr expr ->
tail id (CmmCondBranch e' fid : prev') t bs
_ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
in block' id instrs' : swallow n
LastJump expr params -> endblock $ CmmJump expr params
LastReturn params -> endblock $ CmmReturn params
LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
LastCall tgt args Nothing ->
endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
LastCall tgt args (Just k)
| G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n,
id' == k, unique_pred k ->
let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
in tail id (call : prev') t bs
| G.Block id' t : bs <- n, id' == k, unique_pred k ->
let (ress, srt) = findCopyIn t
call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
delayed = scomment "delayed CopyIn follows previous call"
in tail id (delayed : call : prev') t bs
| otherwise -> panic "unrepairable call"
findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
findCopyIn (G.ZTail _ t) = findCopyIn t
findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
exit id prev' n = -- highly irregular (assertion violation?)
let endblock stmt = block' id (stmt : prev') : swallow n in
case n of [] -> endblock (scomment "procedure falls off end")
G.Block id' t : bs ->
if unique_pred id' then
tail id (scomment "went thru exit" : prev') t bs
else
endblock (CmmBranch id')
preds = zipPreds g
single_preds =
let add b single =
let id = G.blockId b
in case G.lookupBlockEnv preds id of
Nothing -> single
Just s -> if sizeUniqSet s == 1 then
G.extendBlockSet single id
else single
in G.fold_blocks add G.emptyBlockSet g
unique_pred id = G.elemBlockSet id single_preds
call_succs =
let add b succs =
case G.last (G.unzip b) of
G.LastOther (LastCall _ _ (Just id)) -> extendBlockSet succs id
_ -> succs
in G.fold_blocks add emptyBlockSet g
_is_call_succ id = elemBlockSet id call_succs
scomment :: String -> CmmStmt
scomment s = CmmComment $ mkFastString s
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module CmmExpr
( CmmExpr(..), cmmExprRep, maybeInvertCmmExpr
, CmmReg(..), cmmRegRep
, CmmLit(..), cmmLitRep
, LocalReg(..), localRegRep, localRegGCFollow, Kind(..)
, GlobalReg(..), globalRegRep, spReg, hpReg, spLimReg, nodeReg, node
, UserOfLocalRegs, foldRegsUsed
, RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
, plusRegSet, minusRegSet
)
where
import CLabel
import MachOp
import Unique
import UniqSet
-----------------------------------------------------------------------------
-- CmmExpr
-- An expression. Expressions have no side effects.
-----------------------------------------------------------------------------
data CmmExpr
= CmmLit CmmLit -- Literal
| CmmLoad CmmExpr MachRep -- Read memory location
| CmmReg CmmReg -- Contents of register
| CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.)
| CmmRegOff CmmReg Int
-- CmmRegOff reg i
-- ** is shorthand only, meaning **
-- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
-- where rep = cmmRegRep reg
deriving Eq
data CmmReg
= CmmLocal LocalReg
| CmmGlobal GlobalReg
deriving( Eq )
data CmmLit
= CmmInt Integer MachRep
-- Interpretation: the 2's complement representation of the value
-- is truncated to the specified size. This is easier than trying
-- to keep the value within range, because we don't know whether
-- it will be used as a signed or unsigned value (the MachRep doesn't
-- distinguish between signed & unsigned).
| CmmFloat Rational MachRep
| CmmLabel CLabel -- Address of label
| CmmLabelOff CLabel Int -- Address of label + byte offset
-- Due to limitations in the C backend, the following
-- MUST ONLY be used inside the info table indicated by label2
-- (label2 must be the info label), and label1 must be an
-- SRT, a slow entrypoint or a large bitmap (see the Mangler)
-- Don't use it at all unless tablesNextToCode.
-- It is also used inside the NCG during when generating
-- position-independent code.
| CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset
deriving Eq
instance Eq LocalReg where
(LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2
instance Uniquable LocalReg where
getUnique (LocalReg uniq _ _) = uniq
--------
--- Negation for conditional branches
maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
return (CmmMachOp op' args)
maybeInvertCmmExpr _ = Nothing
-----------------------------------------------------------------------------
-- Local registers
-----------------------------------------------------------------------------
-- | Whether a 'LocalReg' is a GC followable pointer
data Kind = KindPtr | KindNonPtr deriving (Eq)
data LocalReg
= LocalReg
!Unique -- ^ Identifier
MachRep -- ^ Type
Kind -- ^ Should the GC follow as a pointer
-- | Sets of local registers
type RegSet = UniqSet LocalReg
emptyRegSet :: RegSet
elemRegSet :: LocalReg -> RegSet -> Bool
extendRegSet :: RegSet -> LocalReg -> RegSet
deleteFromRegSet :: RegSet -> LocalReg -> RegSet
mkRegSet :: [LocalReg] -> RegSet
minusRegSet, plusRegSet :: RegSet -> RegSet -> RegSet
emptyRegSet = emptyUniqSet
elemRegSet = elementOfUniqSet
extendRegSet = addOneToUniqSet
deleteFromRegSet = delOneFromUniqSet
mkRegSet = mkUniqSet
minusRegSet = minusUniqSet
plusRegSet = unionUniqSets
-----------------------------------------------------------------------------
-- Register-use information for expressions and other types
-----------------------------------------------------------------------------
class UserOfLocalRegs a where
foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
instance UserOfLocalRegs CmmReg where
foldRegsUsed f z (CmmLocal reg) = f z reg
foldRegsUsed _ z (CmmGlobal _) = z
instance UserOfLocalRegs LocalReg where
foldRegsUsed f z r = f z r
instance UserOfLocalRegs CmmExpr where
foldRegsUsed f z e = expr z e
where expr z (CmmLit _) = z
expr z (CmmLoad addr _) = foldRegsUsed f z addr
expr z (CmmReg r) = foldRegsUsed f z r
expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
expr z (CmmRegOff r _) = foldRegsUsed f z r
instance UserOfLocalRegs a => UserOfLocalRegs [a] where
foldRegsUsed _ set [] = set
foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
-----------------------------------------------------------------------------
-- MachRep
-----------------------------------------------------------------------------
cmmExprRep :: CmmExpr -> MachRep
cmmExprRep (CmmLit lit) = cmmLitRep lit
cmmExprRep (CmmLoad _ rep) = rep
cmmExprRep (CmmReg reg) = cmmRegRep reg
cmmExprRep (CmmMachOp op _) = resultRepOfMachOp op
cmmExprRep (CmmRegOff reg _) = cmmRegRep reg
cmmRegRep :: CmmReg -> MachRep
cmmRegRep (CmmLocal reg) = localRegRep reg
cmmRegRep (CmmGlobal reg) = globalRegRep reg
localRegRep :: LocalReg -> MachRep
localRegRep (LocalReg _ rep _) = rep
localRegGCFollow :: LocalReg -> Kind
localRegGCFollow (LocalReg _ _ p) = p
cmmLitRep :: CmmLit -> MachRep
cmmLitRep (CmmInt _ rep) = rep
cmmLitRep (CmmFloat _ rep) = rep
cmmLitRep (CmmLabel _) = wordRep
cmmLitRep (CmmLabelOff _ _) = wordRep
cmmLitRep (CmmLabelDiffOff _ _ _) = wordRep
-----------------------------------------------------------------------------
-- Global STG registers
-----------------------------------------------------------------------------
data GlobalReg
-- Argument and return registers
= VanillaReg -- pointers, unboxed ints and chars
{-# UNPACK #-} !Int -- its number
| FloatReg -- single-precision floating-point registers
{-# UNPACK #-} !Int -- its number
| DoubleReg -- double-precision floating-point registers
{-# UNPACK #-} !Int -- its number
| LongReg -- long int registers (64-bit, really)
{-# UNPACK #-} !Int -- its number
-- STG registers
| Sp -- Stack ptr; points to last occupied stack location.
| SpLim -- Stack limit
| Hp -- Heap ptr; points to last occupied heap location.
| HpLim -- Heap limit register
| CurrentTSO -- pointer to current thread's TSO
| CurrentNursery -- pointer to allocation area
| HpAlloc -- allocation count for heap check failure
-- We keep the address of some commonly-called
-- functions in the register table, to keep code
-- size down:
| GCEnter1 -- stg_gc_enter_1
| GCFun -- stg_gc_fun
-- Base offset for the register table, used for accessing registers
-- which do not have real registers assigned to them. This register
-- will only appear after we have expanded GlobalReg into memory accesses
-- (where necessary) in the native code generator.
| BaseReg
-- Base Register for PIC (position-independent code) calculations
-- Only used inside the native code generator. It's exact meaning differs
-- from platform to platform (see module PositionIndependentCode).
| PicBaseReg
deriving( Eq
#ifdef DEBUG
, Show
#endif
)
-- convenient aliases
spReg, hpReg, spLimReg, nodeReg :: CmmReg
spReg = CmmGlobal Sp
hpReg = CmmGlobal Hp
spLimReg = CmmGlobal SpLim
nodeReg = CmmGlobal node
node :: GlobalReg
node = VanillaReg 1
globalRegRep :: GlobalReg -> MachRep
globalRegRep (VanillaReg _) = wordRep
globalRegRep (FloatReg _) = F32
globalRegRep (DoubleReg _) = F64
globalRegRep (LongReg _) = I64
globalRegRep _ = wordRep
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module CmmLiveZ
( CmmLive
, cmmLivenessZ
, liveLattice
, middleLiveness, lastLiveness
)
where
import Cmm
import CmmExpr
import CmmTx
import DFMonad
import Maybes
import PprCmm()
import PprCmmZ()
import UniqSet
import ZipDataflow
import ZipCfgCmm
-----------------------------------------------------------------------------
-- Calculating what variables are live on entry to a basic block
-----------------------------------------------------------------------------
-- | The variables live on entry to a block
type CmmLive = RegSet
-- | The dataflow lattice
liveLattice :: DataflowLattice CmmLive
liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add False
where add new old =
let join = unionUniqSets new old in
(if sizeUniqSet join > sizeUniqSet old then aTx else noTx) join
-- | A mapping from block labels to the variables live on entry
type BlockEntryLiveness = BlockEnv CmmLive
-----------------------------------------------------------------------------
-- | Calculated liveness info for a list of 'CmmBasicBlock'
-----------------------------------------------------------------------------
cmmLivenessZ :: CmmGraph -> BlockEntryLiveness
cmmLivenessZ g = env
where env = runDFA liveLattice $
do run_b_anal transfer g
allFacts
transfer = BComp "liveness analysis" exit last middle first
exit = emptyUniqSet
first live _ = live
middle = flip middleLiveness
last = flip lastLiveness
-- | The transfer equations use the traditional 'gen' and 'kill'
-- notations, which should be familiar from the dragon book.
gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
gen a live = foldRegsUsed extendRegSet live a
kill a live = foldRegsUsed delOneFromUniqSet live a
middleLiveness :: Middle -> CmmLive -> CmmLive
middleLiveness m = middle m
where middle (MidNop) = id
middle (MidComment {}) = id
middle (MidAssign lhs expr) = gen expr . kill lhs
middle (MidStore addr rval) = gen addr . gen rval
middle (MidUnsafeCall tgt ress args) = gen tgt . gen args . kill ress
middle (CopyIn _ formals _) = kill formals
middle (CopyOut _ formals) = gen formals
lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive
lastLiveness l env = last l
where last (LastReturn ress) = gen ress emptyUniqSet
last (LastJump e args) = gen e $ gen args emptyUniqSet