compiler/cmm/CmmLiveZ.hs

   1
   2 module CmmLiveZ
   3     ( CmmLive
   4     , cmmLivenessZ
   5     , liveLattice
   6     , middleLiveness, lastLiveness, noLiveOnEntry
   7     )
   8 where
   9
  10 import BlockId
  11 import CmmExpr
  12 import CmmTx
  13 import DFMonad
  14 import Monad
  15 import PprCmm()
  16 import PprCmmZ()
  17 import ZipCfg
  18 import ZipDataflow
  19 import ZipCfgCmmRep
  20
  21 import Maybes
  22 import Outputable
  23 import UniqSet
  24
  25 -----------------------------------------------------------------------------
  26 -- Calculating what variables are live on entry to a basic block
  27 -----------------------------------------------------------------------------
  28
  29 -- | The variables live on entry to a block
  30 type CmmLive = RegSet
  31
  32 -- | The dataflow lattice
  33 liveLattice :: DataflowLattice CmmLive
  34 liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add False
  35     where add new old =
  36             let join = unionUniqSets new old in
  37             (if sizeUniqSet join > sizeUniqSet old then aTx else noTx) join
  38
  39 -- | A mapping from block labels to the variables live on entry
  40 type BlockEntryLiveness = BlockEnv CmmLive
  41
  42 -----------------------------------------------------------------------------
  43 -- | Calculated liveness info for a CmmGraph
  44 -----------------------------------------------------------------------------
  45 cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness
  46 cmmLivenessZ g@(LGraph entry _ _) =
  47   liftM (check . zdfFpFacts) (res :: FuelMonad (CmmBackwardFixedPoint CmmLive))
  48   where res = zdfSolveFrom emptyBlockEnv "liveness analysis" liveLattice transfers
  49                            emptyUniqSet (graphOfLGraph g)
  50         transfers = BackwardTransfers first middle last
  51         first live _ = live
  52         middle       = flip middleLiveness
  53         last         = flip lastLiveness
  54         check facts  =
  55           noLiveOnEntry entry (expectJust "check" $ lookupBlockEnv facts entry) facts
  56
  57 -- | On entry to the procedure, there had better not be any LocalReg's live-in.
  58 noLiveOnEntry :: BlockId -> CmmLive -> a -> a
  59 noLiveOnEntry bid in_fact x =
  60   if isEmptyUniqSet in_fact then x
  61   else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
  62
  63 -- | The transfer equations use the traditional 'gen' and 'kill'
  64 -- notations, which should be familiar from the dragon book.
  65 gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
  66 gen  a live = foldRegsUsed extendRegSet      live a
  67 kill a live = foldRegsUsed delOneFromUniqSet live a
  68
  69 -- Why aren't these function using the typeclasses on Middle and Last?
  70 middleLiveness :: Middle -> CmmLive -> CmmLive
  71 middleLiveness (MidComment {})            live = live
  72 middleLiveness (MidAssign lhs expr)       live = gen expr $ kill lhs live
  73 middleLiveness (MidStore addr rval)       live = gen addr $ gen rval live
  74 middleLiveness (MidForeignCall _ tgt _ args) _ = gen tgt $ gen args emptyUniqSet
  75
  76 lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive
  77 lastLiveness l env = last l
  78   where last (LastBranch id)             = env id
  79         last (LastCall tgt Nothing  _ _) = gen tgt $ emptyUniqSet
  80         last (LastCall tgt (Just k) _ _) = gen tgt $ env k
  81         last (LastCondBranch e t f)      = gen e $ unionUniqSets (env t) (env f)
  82         last (LastSwitch e tbl)          =
  83           gen e $ unionManyUniqSets $ map env (catMaybes tbl)