cmm/Hoopl/Dataflow.hs

    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE GADTs #-}
    {-# LANGUAGE MultiParamTypeClasses  #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TypeFamilies #-}
    {-# OPTIONS_GHC -fprof-auto-top #-}

    --
    -- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,
    -- and Norman Ramsey
    --
    -- Modifications copyright (c) The University of Glasgow 2012
    --
    -- This module is a specialised and optimised version of
    -- Compiler.Hoopl.Dataflow in the hoopl package.  In particular it is
    -- specialised to the UniqSM monad.
    --

    module Hoopl.Dataflow
      ( C, O, Block
      , lastNode, entryLabel
      , foldNodesBwdOO
      , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..), TransferFun
      , Fact, FactBase
      , getFact, mkFactBase
      , analyzeCmmFwd, analyzeCmmBwd
      , changedIf
      , joinOutFacts
      )
    where

    import Cmm

    import Data.Array
    import Data.List
    import Data.Maybe

    -- Hide definitions from Hoopl's Dataflow module.
    import Compiler.Hoopl hiding ( DataflowLattice, OldFact, NewFact, JoinFun
                                 , fact_bot, fact_join, joinOutFacts, mkFactBase
                                 )

    newtype OldFact a = OldFact a

    newtype NewFact a = NewFact a

    -- | The result of joining OldFact and NewFact.
    data JoinedFact a
        = Changed !a     -- ^ Result is different than OldFact.
        | NotChanged !a  -- ^ Result is the same as OldFact.

    getJoined :: JoinedFact a -> a
    getJoined (Changed a) = a
    getJoined (NotChanged a) = a

    changedIf :: Bool -> a -> JoinedFact a
    changedIf True = Changed
    changedIf False = NotChanged

    type JoinFun a = OldFact a -> NewFact a -> JoinedFact a

    data DataflowLattice a = DataflowLattice
        { fact_bot :: a
        , fact_join :: JoinFun a
        }

    data Direction = Fwd | Bwd

    type TransferFun f = CmmBlock -> FactBase f -> FactBase f

    analyzeCmmBwd, analyzeCmmFwd
        :: DataflowLattice f
        -> TransferFun f
        -> CmmGraph
        -> FactBase f
        -> FactBase f
    analyzeCmmBwd = analyzeCmm Bwd
    analyzeCmmFwd = analyzeCmm Fwd

    analyzeCmm
        :: Direction
        -> DataflowLattice f
        -> TransferFun f
        -> CmmGraph
        -> FactBase f
        -> FactBase f
    analyzeCmm dir lattice transfer cmmGraph initFact =
        let entry = g_entry cmmGraph
            hooplGraph = g_graph cmmGraph
            blockMap =
                case hooplGraph of
                    GMany NothingO bm NothingO -> bm
            entries = if mapNull initFact then [entry] else mapKeys initFact
        in fixpointAnalysis dir lattice transfer entries blockMap initFact

    -- Fixpoint algorithm.
    fixpointAnalysis
        :: forall f.
           Direction
        -> DataflowLattice f
        -> TransferFun f
        -> [Label]
        -> LabelMap CmmBlock
        -> FactBase f
        -> FactBase f
    fixpointAnalysis direction lattice do_block entries blockmap = loop start
      where
        -- Sorting the blocks helps to minimize the number of times we need to
        -- process blocks. For instance, for forward analysis we want to look at
        -- blocks in reverse postorder. Also, see comments for sortBlocks.
        blocks     = sortBlocks direction entries blockmap
        num_blocks = length blocks
        block_arr  = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
        start      = {-# SCC "start" #-} [0 .. num_blocks - 1]
        dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
        join       = fact_join lattice

        loop
            :: IntHeap     -- ^ Worklist, i.e., blocks to process
            -> FactBase f  -- ^ Current result (increases monotonically)
            -> FactBase f
        loop []              !fbase1 = fbase1
        loop (index : todo1) !fbase1 =
            let block = block_arr ! index
                out_facts = {-# SCC "do_block" #-} do_block block fbase1
                -- For each of the outgoing edges, we join it with the current
                -- information in fbase1 and (if something changed) we update it
                -- and add the affected blocks to the worklist.
                (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}
                    mapFoldWithKey
                        (updateFact join dep_blocks) (todo1, fbase1) out_facts
            in loop todo2 fbase2

    {-
    Note [Unreachable blocks]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    A block that is not in the domain of tfb_fbase is "currently unreachable".
    A currently-unreachable block is not even analyzed.  Reason: consider
    constant prop and this graph, with entry point L1:
      L1: x:=3; goto L4
      L2: x:=4; goto L4
      L4: if x>3 goto L2 else goto L5
    Here L2 is actually unreachable, but if we process it with bottom input fact,
    we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.

    * If a currently-unreachable block is not analyzed, then its rewritten
      graph will not be accumulated in tfb_rg.  And that is good:
      unreachable blocks simply do not appear in the output.

    * Note that clients must be careful to provide a fact (even if bottom)
      for each entry point. Otherwise useful blocks may be garbage collected.

    * Note that updateFact must set the change-flag if a label goes from
      not-in-fbase to in-fbase, even if its fact is bottom.  In effect the
      real fact lattice is
           UNR
           bottom
           the points above bottom

    * Even if the fact is going from UNR to bottom, we still call the
      client's fact_join function because it might give the client
      some useful debugging information.

    * All of this only applies for *forward* ixpoints.  For the backward
      case we must treat every block as reachable; it might finish with a
      'return', and therefore have no successors, for example.
    -}

    -----------------------------------------------------------------------------
    --  Pieces that are shared by fixpoint and fixpoint_anal
    -----------------------------------------------------------------------------

    -- | Sort the blocks into the right order for analysis. This means reverse
    -- postorder for a forward analysis. For the backward one, we simply reverse
    -- that (see Note [Backward vs forward analysis]).
    --
    -- Note: We're using Hoopl's confusingly named `postorder_dfs_from` but AFAICS
    -- it returns the *reverse* postorder of the blocks (it visits blocks in the
    -- postorder and uses (:) to collect them, which gives the reverse of the
    -- visitation order).
    sortBlocks
        :: NonLocal n
        => Direction -> [Label] -> LabelMap (Block n C C) -> [Block n C C]
    sortBlocks direction entries blockmap =
        case direction of
            Fwd -> fwd
            Bwd -> reverse fwd
      where
        fwd = postorder_dfs_from blockmap entries

    -- Note [Backward vs forward analysis]
    --
    -- The forward and backward cases are not dual.  In the forward case, the entry
    -- points are known, and one simply traverses the body blocks from those points.
    -- In the backward case, something is known about the exit points, but a
    -- backward analysis must also include reachable blocks that don't reach the
    -- exit, as in a procedure that loops forever and has side effects.)
    -- For instance, let E be the entry and X the exit blocks (arrows indicate
    -- control flow)
    --   E -> X
    --   E -> B
    --   B -> C
    --   C -> B
    -- We do need to include B and C even though they're unreachable in the
    -- *reverse* graph (that we could use for backward analysis):
    --   E <- X
    --   E <- B
    --   B <- C
    --   C <- B
    -- So when sorting the blocks for the backward analysis, we simply take the
    -- reverse of what is used for the forward one.

    -- | construct a mapping from L -> block indices.  If the fact for L
    -- changes, re-analyse the given blocks.
    mkDepBlocks :: NonLocal n => Direction -> [Block n C C] -> LabelMap [Int]
    mkDepBlocks Fwd blocks = go blocks 0 mapEmpty
      where go []     !_  m = m
            go (b:bs) !n m = go bs (n+1) $! mapInsert (entryLabel b) [n] m
    mkDepBlocks Bwd blocks = go blocks 0 mapEmpty
      where go []     !_ m = m
            go (b:bs) !n m = go bs (n+1) $! go' (successors b) m
                where go' [] m = m
                      go' (l:ls) m = go' ls (mapInsertWith (++) l [n] m)

    -- | After some new facts have been generated by analysing a block, we
    -- fold this function over them to generate (a) a list of block
    -- indices to (re-)analyse, and (b) the new FactBase.
    --
    updateFact :: JoinFun f -> LabelMap [Int]
               -> Label -> f       -- out fact
               -> (IntHeap, FactBase f)
               -> (IntHeap, FactBase f)

    updateFact fact_join dep_blocks lbl new_fact (todo, fbase)
      = case lookupFact lbl fbase of
          Nothing       -> let !z = mapInsert lbl new_fact fbase in (changed, z)
                               -- Note [no old fact]
          Just old_fact ->
            case fact_join (OldFact old_fact) (NewFact new_fact) of
              (NotChanged _) -> (todo, fbase)
              (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)
      where
         changed = foldr insertIntHeap todo $
                     mapFindWithDefault [] lbl dep_blocks

    {-
    Note [no old fact]

    We know that the new_fact is >= _|_, so we don't need to join.  However,
    if the new fact is also _|_, and we have already analysed its block,
    we don't need to record a change.  So there's a tradeoff here.  It turns
    out that always recording a change is faster.
    -}

    ----------------------------------------------------------------
    --       Utilities
    ----------------------------------------------------------------

    -- Fact lookup: the fact `orelse` bottom
    getFact  :: DataflowLattice f -> Label -> FactBase f -> f
    getFact lat l fb = case lookupFact l fb of Just  f -> f
                                               Nothing -> fact_bot lat

    -- | Returns the result of joining the facts from all the successors of the
    -- provided node or block.
    joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f
    joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
      where
        join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
        facts =
            [ fromJust fact
            | s <- successors nonLocal
            , let fact = lookupFact s fact_base
            , isJust fact
            ]

    -- | Returns the joined facts for each label.
    mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
    mkFactBase lattice = foldl' add mapEmpty
      where
        join = fact_join lattice

        add result (l, f1) =
            let !newFact =
                    case mapLookup l result of
                        Nothing -> f1
                        Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)
            in mapInsert l newFact result

    -- | Folds backward over all nodes of an open-open block.
    -- Strict in the accumulator.
    foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
    foldNodesBwdOO funOO = go
      where
        go (BCat b1 b2) f = go b1 $! go b2 f
        go (BSnoc h n) f = go h $! funOO n f
        go (BCons n t) f = funOO n $! go t f
        go (BMiddle n) f = funOO n f
        go BNil f = f
    {-# INLINABLE foldNodesBwdOO #-}

    -- -----------------------------------------------------------------------------
    -- a Heap of Int

    -- We should really use a proper Heap here, but my attempts to make
    -- one have not succeeded in beating the simple ordered list.  Another
    -- alternative is IntSet (using deleteFindMin), but that was also
    -- slower than the ordered list in my experiments --SDM 25/1/2012

    type IntHeap = [Int] -- ordered

    insertIntHeap :: Int -> [Int] -> [Int]
    insertIntHeap x [] = [x]
    insertIntHeap x (y:ys)
      | x < y     = x : y : ys
      | x == y    = x : ys
      | otherwise = y : insertIntHeap x ys