compiler/cmm/CmmLive.hs

   1 {-# LANGUAGE GADTs #-}
   2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
   3
   4 module CmmLive
   5     ( CmmLive
   6     , cmmLiveness
   7     , liveLattice
   8     , noLiveOnEntry, xferLive
   9     )
  10 where
  11
  12 import BlockId
  13 import Cmm
  14 import CmmExpr
  15 import Control.Monad
  16 import OptimizationFuel
  17 import PprCmmExpr ()
  18
  19 import Compiler.Hoopl
  20 import Maybes
  21 import Outputable
  22 import UniqSet
  23
  24 -----------------------------------------------------------------------------
  25 -- Calculating what variables are live on entry to a basic block
  26 -----------------------------------------------------------------------------
  27
  28 -- | The variables live on entry to a block
  29 type CmmLive = RegSet
  30
  31 -- | The dataflow lattice
  32 liveLattice :: DataflowLattice CmmLive
  33 liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add
  34     where add _ (OldFact old) (NewFact new) = case unionUniqSets old new of
  35             join -> (changeIf $ sizeUniqSet join > sizeUniqSet old, join)
  36
  37 -- | A mapping from block labels to the variables live on entry
  38 type BlockEntryLiveness = BlockEnv CmmLive
  39
  40 -----------------------------------------------------------------------------
  41 -- | Calculated liveness info for a CmmGraph
  42 -----------------------------------------------------------------------------
  43
  44 cmmLiveness :: CmmGraph -> FuelUniqSM BlockEntryLiveness
  45 cmmLiveness graph =
  46   liftM check $ liftM snd $ dataflowPassBwd graph [] $ analBwd liveLattice xferLive
  47   where entry = g_entry graph
  48         check facts = noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts
  49
  50 gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive
  51 gen_kill a = gen a . kill a
  52
  53 -- | On entry to the procedure, there had better not be any LocalReg's live-in.
  54 noLiveOnEntry :: BlockId -> CmmLive -> a -> a
  55 noLiveOnEntry bid in_fact x =
  56   if isEmptyUniqSet in_fact then x
  57   else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
  58
  59 -- | The transfer equations use the traditional 'gen' and 'kill'
  60 -- notations, which should be familiar from the dragon book.
  61 gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
  62 gen  a live = foldRegsUsed    extendRegSet      live a
  63 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
  64 kill a live = foldRegsDefd delOneFromUniqSet live a
  65
  66 -- Testing!
  67 xferLive :: BwdTransfer CmmNode CmmLive
  68 xferLive = mkBTransfer3 fst mid lst
  69   where fst _ f = f
  70         mid :: CmmNode O O -> CmmLive -> CmmLive
  71         mid n f = gen_kill n f
  72         lst :: CmmNode O C -> FactBase CmmLive -> CmmLive
  73         lst n f = gen_kill n $ case n of CmmCall {}            -> emptyRegSet
  74                                          CmmForeignCall {}     -> emptyRegSet
  75                                          _                     -> joinOutFacts liveLattice n f