Ticket #3224: CmmLiveZ.hs

module CmmLiveZ
    ( CmmLive
    , cmmLivenessZ
    , liveLattice
    , middleLiveness
    ) 
where

import BlockId
import CmmExpr
import CmmTx
import DFLattice
import PprCmm()
import PprCmmZ()
import ZDF5ex -- was ZipDataflow
import ZipCfgCmmRep

import Maybes
import Outputable
import UniqSet

-----------------------------------------------------------------------------
-- 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 CmmGraph
-----------------------------------------------------------------------------
cmmLivenessZ :: CmmGraph -> BlockEntryLiveness
cmmLivenessZ g = zdfFpFacts $ check res
  where res :: CmmBackwardFixedPoint CmmLive
        res = zdfSolveFromBwd emptyBlockEnv "liveness analysis"
              liveLattice transfers g
        transfers = BackwardTransfers (flip const) mid last
        mid  m = gen_kill m . midLive  m
        last l = gen_kill l . lastLive l 
        check :: CmmBackwardFixedPoint CmmLive -> CmmBackwardFixedPoint CmmLive
        check bfp = noLive (bfp_out_fact bfp) bfp

gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive
gen_kill a = gen a . kill a

middleLiveness :: Middle -> CmmLive -> CmmLive
middleLiveness = gen_kill

-- | On entry to the procedure, there had better not be any LocalReg's live-in.
noLive :: CmmLive -> a -> a
noLive in_fact x =
  if isEmptyUniqSet in_fact then x
  else pprPanic "LocalReg's live-in to graph" (ppr in_fact)

-- | The transfer equations use the traditional 'gen' and 'kill'
-- notations, which should be familiar from the dragon book.
gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
gen  a live = foldRegsUsed    extendRegSet      live a
kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
kill a live = foldRegsDefd delOneFromUniqSet live a

midLive :: Middle -> CmmLive -> CmmLive
midLive (MidForeignCall {}) _ = emptyUniqSet
midLive _                live = live

lastLive :: Last -> (BlockId -> CmmLive) -> CmmLive
lastLive l env = last l
  where last (LastBranch id)        = env id
        last (LastCall _ _  _ _ _)  = emptyUniqSet
        last (LastCondBranch _ t f) = unionUniqSets (env t) (env f)
        last (LastSwitch _ tbl)     = unionManyUniqSets $ map env (catMaybes tbl)

can't_match :: a
can't_match = panic "the GADT pattern matcher is too stupid to live"