Dataflow.hs 14.1 KB
Newer Older
1 2 3 4 5 6 7 8
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fprof-auto-top #-}

9 10 11 12 13 14 15 16 17 18 19
--
-- 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.
--

Simon Marlow's avatar
Simon Marlow committed
20
module Hoopl.Dataflow
21 22
  ( C, O, DataflowLattice(..), OldFact(..), NewFact(..), Fact, FactBase
  , mkFactBase
Simon Marlow's avatar
Simon Marlow committed
23
  , ChangeFlag(..)
24
  , FwdPass(..), FwdTransfer, mkFTransfer3
Simon Marlow's avatar
Simon Marlow committed
25

26
  , BwdPass(..), BwdTransfer, mkBTransfer3
27

28
  , dataflowAnalFwdBlocks, dataflowAnalBwd
29
  , analyzeFwd, analyzeFwdBlocks, analyzeBwd
30 31 32

  , changeIf
  , joinOutFacts
Simon Marlow's avatar
Simon Marlow committed
33 34 35
  )
where

36 37
import BlockId
import Cmm
Simon Marlow's avatar
Simon Marlow committed
38

39
import Data.Array
Simon Marlow's avatar
Simon Marlow committed
40

41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
import Compiler.Hoopl

-- TODO(michalt): This wrapper will go away once we refactor the analyze*
-- methods.
dataflowAnalFwdBlocks
    :: NonLocal n
    => GenCmmGraph n
    -> [(BlockId, f)]
    -> DataflowLattice f
    -> FwdTransfer n f
    -> BlockEnv f
dataflowAnalFwdBlocks
        (CmmGraph {g_entry = entry, g_graph = graph}) facts lattice xfer =
    analyzeFwdBlocks
        lattice xfer (JustC [entry]) graph (mkFactBase lattice facts)

-- TODO(michalt): This wrapper will go away once we refactor the analyze*
-- methods.
dataflowAnalBwd
    :: NonLocal n
    => GenCmmGraph n
    -> [(BlockId, f)]
    -> DataflowLattice f
    -> BwdTransfer n f
    -> BlockEnv f
dataflowAnalBwd
        (CmmGraph {g_entry = entry, g_graph = graph}) facts lattice xfer =
    analyzeBwd lattice xfer (JustC [entry]) graph (mkFactBase lattice facts)
Simon Marlow's avatar
Simon Marlow committed
69 70 71 72 73 74 75 76 77


----------------------------------------------------------------
--       Forward Analysis only
----------------------------------------------------------------

-- | if the graph being analyzed is open at the entry, there must
--   be no other entry point, or all goes horribly wrong...
analyzeFwd
78 79 80
   :: forall n f e .  NonLocal n
   => DataflowLattice f
   -> FwdTransfer n f
Simon Marlow's avatar
Simon Marlow committed
81 82 83
   -> MaybeC e [Label]
   -> Graph n e C -> Fact e f
   -> FactBase f
84 85
analyzeFwd lattice (FwdTransfer3 (ftr, mtr, ltr)) entries g in_fact =
    graph g in_fact
Simon Marlow's avatar
Simon Marlow committed
86 87 88 89 90 91 92 93 94
  where
    graph :: Graph n e C -> Fact e f -> FactBase f
    graph (GMany entry blockmap NothingO)
      = case (entries, entry) of
         (NothingC, JustO entry)   -> block entry `cat` body (successors entry)
         (JustC entries, NothingO) -> body entries
     where
       body  :: [Label] -> Fact C f -> Fact C f
       body entries f
Simon Marlow's avatar
Simon Marlow committed
95
         = fixpointAnal Fwd lattice do_block entries blockmap f
Simon Marlow's avatar
Simon Marlow committed
96 97 98 99 100
         where
           do_block :: forall x . Block n C x -> FactBase f -> Fact x f
           do_block b fb = block b entryFact
             where entryFact = getFact lattice (entryLabel b) fb

101
    -- NB. eta-expand block, GHC can't do this by itself.  See #5809.
Simon Marlow's avatar
Simon Marlow committed
102
    block :: forall e x . Block n e x -> f -> Fact x f
103
    block BNil            f = f
104 105 106
    block (BlockCO n b)   f = (ftr n `cat`  block b) f
    block (BlockCC l b n) f = (ftr l `cat` (block b `cat` ltr n)) f
    block (BlockOC   b n) f =              (block b `cat` ltr n) f
Simon Marlow's avatar
Simon Marlow committed
107

Simon Marlow's avatar
Simon Marlow committed
108 109
    block (BMiddle n)     f = mtr n f
    block (BCat b1 b2)    f = (block b1 `cat` block b2) f
110 111
    block (BSnoc h n)     f = (block h  `cat` mtr n) f
    block (BCons n t)     f = (mtr  n   `cat` block t) f
Simon Marlow's avatar
Simon Marlow committed
112 113

    {-# INLINE cat #-}
114
    cat :: forall f1 f2 f3 . (f1 -> f2) -> (f2 -> f3) -> (f1 -> f3)
115 116 117 118 119
    cat ft1 ft2 = \f -> ft2 $! ft1 f

-- | if the graph being analyzed is open at the entry, there must
--   be no other entry point, or all goes horribly wrong...
analyzeFwdBlocks
120 121 122
   :: forall n f e .  NonLocal n
   => DataflowLattice f
   -> FwdTransfer n f
123 124 125
   -> MaybeC e [Label]
   -> Graph n e C -> Fact e f
   -> FactBase f
126 127
analyzeFwdBlocks lattice (FwdTransfer3 (ftr, _, ltr)) entries g in_fact =
    graph g in_fact
128 129 130 131 132 133 134 135 136
  where
    graph :: Graph n e C -> Fact e f -> FactBase f
    graph (GMany entry blockmap NothingO)
      = case (entries, entry) of
         (NothingC, JustO entry)   -> block entry `cat` body (successors entry)
         (JustC entries, NothingO) -> body entries
     where
       body  :: [Label] -> Fact C f -> Fact C f
       body entries f
Simon Marlow's avatar
Simon Marlow committed
137
         = fixpointAnal Fwd lattice do_block entries blockmap f
138 139 140 141 142 143 144 145
         where
           do_block :: forall x . Block n C x -> FactBase f -> Fact x f
           do_block b fb = block b entryFact
             where entryFact = getFact lattice (entryLabel b) fb

    -- NB. eta-expand block, GHC can't do this by itself.  See #5809.
    block :: forall e x . Block n e x -> f -> Fact x f
    block BNil            f = f
146 147 148
    block (BlockCO n _)   f = ftr n f
    block (BlockCC l _ n) f = (ftr l `cat` ltr n) f
    block (BlockOC   _ n) f = ltr n f
149
    block _               _ = error "analyzeFwdBlocks"
150 151

    {-# INLINE cat #-}
152
    cat :: forall f1 f2 f3 . (f1 -> f2) -> (f2 -> f3) -> (f1 -> f3)
153
    cat ft1 ft2 = \f -> ft2 $! ft1 f
Simon Marlow's avatar
Simon Marlow committed
154 155 156 157 158 159 160 161

----------------------------------------------------------------
--       Backward Analysis only
----------------------------------------------------------------

-- | if the graph being analyzed is open at the entry, there must
--   be no other entry point, or all goes horribly wrong...
analyzeBwd
162 163 164
   :: forall n f e .  NonLocal n
   => DataflowLattice f
   -> BwdTransfer n f
Simon Marlow's avatar
Simon Marlow committed
165 166 167
   -> MaybeC e [Label]
   -> Graph n e C -> Fact C f
   -> FactBase f
168 169
analyzeBwd lattice (BwdTransfer3 (ftr, mtr, ltr)) entries g in_fact =
    graph g in_fact
Simon Marlow's avatar
Simon Marlow committed
170 171 172 173 174 175 176 177 178
  where
    graph :: Graph n e C -> Fact C f -> FactBase f
    graph (GMany entry blockmap NothingO)
      = case (entries, entry) of
         (NothingC, JustO entry)   -> body (successors entry)
         (JustC entries, NothingO) -> body entries
     where
       body  :: [Label] -> Fact C f -> Fact C f
       body entries f
Simon Marlow's avatar
Simon Marlow committed
179
         = fixpointAnal Bwd lattice do_block entries blockmap f
Simon Marlow's avatar
Simon Marlow committed
180 181
         where
           do_block :: forall x . Block n C x -> Fact x f -> FactBase f
Simon Marlow's avatar
Simon Marlow committed
182
           do_block b fb = mapSingleton (entryLabel b) (block b fb)
Simon Marlow's avatar
Simon Marlow committed
183

184
    -- NB. eta-expand block, GHC can't do this by itself.  See #5809.
Simon Marlow's avatar
Simon Marlow committed
185
    block :: forall e x . Block n e x -> Fact x f -> f
186
    block BNil            f = f
187 188 189
    block (BlockCO n b)   f = (ftr n `cat`  block b) f
    block (BlockCC l b n) f = ((ftr l `cat` block b) `cat` ltr n) f
    block (BlockOC   b n) f =              (block b `cat` ltr n) f
Simon Marlow's avatar
Simon Marlow committed
190

191 192
    block (BMiddle n)     f = mtr n f
    block (BCat b1 b2)    f = (block b1 `cat` block b2) f
193 194
    block (BSnoc h n)     f = (block h  `cat` mtr n) f
    block (BCons n t)     f = (mtr  n   `cat` block t) f
Simon Marlow's avatar
Simon Marlow committed
195 196

    {-# INLINE cat #-}
197
    cat :: forall f1 f2 f3 . (f2 -> f3) -> (f1 -> f2) -> (f1 -> f3)
198
    cat ft1 ft2 = \f -> ft1 $! ft2 f
Simon Marlow's avatar
Simon Marlow committed
199 200 201


-----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
202
--      fixpoint
Simon Marlow's avatar
Simon Marlow committed
203 204 205
-----------------------------------------------------------------------------

data Direction = Fwd | Bwd
Simon Marlow's avatar
Simon Marlow committed
206

Simon Marlow's avatar
Simon Marlow committed
207 208 209
-- | fixpointing for analysis-only
--
fixpointAnal :: forall n f. NonLocal n
Simon Marlow's avatar
Simon Marlow committed
210 211 212 213 214 215 216
 => Direction
 -> DataflowLattice f
 -> (Block n C C -> Fact C f -> Fact C f)
 -> [Label]
 -> LabelMap (Block n C C)
 -> Fact C f -> FactBase f

217
fixpointAnal direction DataflowLattice{ fact_bot = _, fact_join = join }
218
              do_block entries blockmap init_fbase
219
  = loop start init_fbase
Simon Marlow's avatar
Simon Marlow committed
220
  where
Simon Marlow's avatar
Simon Marlow committed
221 222 223 224 225
    blocks     = sortBlocks direction entries blockmap
    n          = length blocks
    block_arr  = {-# SCC "block_arr" #-} listArray (0,n-1) blocks
    start      = {-# SCC "start" #-} [0..n-1]
    dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
Simon Marlow's avatar
Simon Marlow committed
226 227

    loop
Simon Marlow's avatar
Simon Marlow committed
228
       :: IntHeap      -- blocks still to analyse
229
       -> FactBase f  -- current factbase (increases monotonically)
Simon Marlow's avatar
Simon Marlow committed
230 231
       -> FactBase f

Simon Marlow's avatar
Simon Marlow committed
232
    loop []        fbase = fbase
233
    loop (ix:todo) fbase =
Simon Marlow's avatar
Simon Marlow committed
234 235 236 237
           let
               blk = block_arr ! ix

               out_facts = {-# SCC "do_block" #-} do_block blk fbase
Simon Marlow's avatar
Simon Marlow committed
238

Simon Marlow's avatar
Simon Marlow committed
239
               !(todo', fbase') = {-# SCC "mapFoldWithKey" #-}
Simon Marlow's avatar
Simon Marlow committed
240
                     mapFoldWithKey (updateFact join dep_blocks)
Simon Marlow's avatar
Simon Marlow committed
241
                                    (todo,fbase) out_facts
Simon Marlow's avatar
Simon Marlow committed
242
           in
Simon Marlow's avatar
Simon Marlow committed
243
           -- trace ("analysing: " ++ show (entryLabel blk)) $
Simon Marlow's avatar
Simon Marlow committed
244 245 246 247
           -- trace ("fbase': " ++ show (mapKeys fbase')) $ return ()
           -- trace ("changed: " ++ show changed) $ return ()
           -- trace ("to analyse: " ++ show to_analyse) $ return ()

Simon Marlow's avatar
Simon Marlow committed
248 249 250
           loop todo' fbase'


251
{-
Simon Marlow's avatar
Simon Marlow committed
252 253 254
Note [Unreachable blocks]
~~~~~~~~~~~~~~~~~~~~~~~~~
A block that is not in the domain of tfb_fbase is "currently unreachable".
255
A currently-unreachable block is not even analyzed.  Reason: consider
Simon Marlow's avatar
Simon Marlow committed
256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285
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.
-}

Simon Marlow's avatar
Simon Marlow committed
286 287 288 289 290

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

291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330
-- | 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.

Simon Marlow's avatar
Simon Marlow committed
331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374

-- | 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 lbl (OldFact old_fact) (NewFact new_fact) of
          (NoChange, _) -> (todo, fbase)
          (_,        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.
-}

Simon Marlow's avatar
Simon Marlow committed
375 376 377 378 379 380 381 382 383
----------------------------------------------------------------
--       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

384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399
-- -----------------------------------------------------------------------------
-- 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