Commit dc4d5962 authored by Michal Terepeta's avatar Michal Terepeta Committed by Ben Gamari

Hoopl/Dataflow: make the module more self-contained

This makes the GHC's Dataflow module more self-contained by also
forking the `DataflowLattice` (instead of only the analysis
algorithm). Effects/benefits:
- We no longer need to use the deprecated Hoopl functions (and can
  remove `-fno-warn-warnings-deprecations` from two modules).
- We can remove the unnecessary `Label` parameter of `JoinFun` (already
  ignored in all our implementations).
- We no longer mix Hoopl's `Dataflow` module and GHC's one.
- We can replace some calls to lazy folds in Hoopl with the strict ones
  (see `joinOutFacts` and `mkFactBase`).
Signed-off-by: Michal Terepeta's avatarMichal Terepeta <michal.terepeta@gmail.com>

Test Plan: validate

Reviewers: austin, simonmar, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2660
parent 6fecb7e7
{-# LANGUAGE CPP, GADTs #-}
{-# LANGUAGE BangPatterns, CPP, GADTs #-}
-- See Note [Deprecations in Hoopl] in Hoopl module
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module CmmBuildInfoTables
( CAFSet, CAFEnv, cafAnal
, doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
......@@ -89,9 +87,11 @@ type CAFEnv = BlockEnv CAFSet
-- First, an analysis to find live CAFs.
cafLattice :: DataflowLattice CAFSet
cafLattice = DataflowLattice "live cafs" Set.empty add
where add _ (OldFact old) (NewFact new) = case old `Set.union` new of
new' -> (changeIf $ Set.size new' > Set.size old, new')
cafLattice = DataflowLattice Set.empty add
where
add (OldFact old) (NewFact new) =
let !new' = old `Set.union` new
in changedIf (Set.size new' > Set.size old) new'
cafTransfers :: BwdTransfer CmmNode CAFSet
cafTransfers = mkBTransfer3 first middle last
......
......@@ -3,9 +3,6 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- See Note [Deprecations in Hoopl] in Hoopl module
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module CmmLive
( CmmLocalLive
, cmmLocalLiveness
......@@ -36,10 +33,11 @@ type CmmLocalLive = CmmLive LocalReg
liveLattice :: Ord r => DataflowLattice (CmmLive r)
{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-}
{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-}
liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add
where add _ (OldFact old) (NewFact new) =
(changeIf $ sizeRegSet join > sizeRegSet old, join)
where !join = plusRegSet old new
liveLattice = DataflowLattice emptyRegSet add
where
add (OldFact old) (NewFact new) =
let !join = plusRegSet old new
in changedIf (sizeRegSet join > sizeRegSet old) join
-- | A mapping from block labels to the variables live on entry
......
......@@ -155,14 +155,14 @@ forward = mkFTransfer3 first middle last
last l x = mkFactBase lattice $ map (\id -> (id, x)) (successors l)
lattice :: DataflowLattice Status
lattice = DataflowLattice "direct proc-point reachability" unreached add_to
lattice = DataflowLattice unreached add_to
where unreached = ReachedBy setEmpty
add_to _ (OldFact ProcPoint) _ = (NoChange, ProcPoint)
add_to _ _ (NewFact ProcPoint) = (SomeChange, ProcPoint)
add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
add_to _ (NewFact ProcPoint) = Changed ProcPoint
-- because of previous case
add_to _ (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
| setSize union > setSize p = (SomeChange, ReachedBy union)
| otherwise = (NoChange, ReachedBy p)
add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
| setSize union > setSize p = Changed (ReachedBy union)
| otherwise = NotChanged (ReachedBy p)
where
union = setUnion p' p
......
......@@ -7,39 +7,15 @@ module Hoopl (
import Compiler.Hoopl hiding
( (<*>), mkLabel, mkBranch, mkMiddle, mkLast, -- clashes with our MkGraph
DataflowLattice, OldFact, NewFact, JoinFun,
fact_bot, fact_join, joinOutFacts, mkFactBase,
Unique,
FwdTransfer(..), FwdRewrite(..), FwdPass(..),
BwdTransfer(..), BwdRewrite(..), BwdPass(..),
mkFactBase, Fact,
mkBRewrite3, mkBTransfer3,
mkFRewrite3, mkFTransfer3,
)
import Hoopl.Dataflow
-- Note [Deprecations in Hoopl]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- CmmLive and CmmBuildInfoTables modules enable -fno-warn-warnings-deprecations
-- flag because they import deprecated functions from Hoopl. I spent some time
-- trying to figure out what is going on, so here's a brief explanation. The
-- culprit is the joinOutFacts function, which should be replaced with
-- joinFacts. The difference between them is that the latter one needs extra
-- Label parameter. Labels identify blocks and are used in the fact base to
-- assign facts to a block (in case you're wondering, Label is an Int wrapped in
-- a newtype). Lattice join function is also required to accept a Label but the
-- only reason why it is so are the debugging purposes: see joinInFacts function
-- which is a no-op and is run only because join function might produce
-- debugging output. Now, going back to the Cmm modules. The "problem" with the
-- deprecated joinOutFacts function is that it passes wrong label when calling
-- lattice join function: instead of label of a block for which we are joining
-- facts it uses labels of successors of that block. So the joinFacts function
-- expects to be given a label of a block for which we are joining facts. I
-- don't see an obvious way of recovering that Label at the call sites of
-- joinOutFacts (if that was easily done then joinFacts function could do it
-- internally without requiring label as a parameter). A cheap way of
-- eliminating these warnings would be to create a bogus Label, since none of
-- our join functions is actually using the Label parameter. But that doesn't
-- feel right. I think the real solution here is to fix Hoopl API, which is
-- already broken in several ways. See Hoopl/Cleanup page on the wiki for more
-- notes on improving Hoopl.
......@@ -20,7 +20,7 @@
module Hoopl.Dataflow
( C, O, DataflowLattice(..), OldFact(..), NewFact(..), Fact, FactBase
, mkFactBase
, ChangeFlag(..)
, JoinedFact(..)
, FwdPass(..), FwdTransfer, mkFTransfer3
, BwdPass(..), BwdTransfer, mkBTransfer3
......@@ -28,7 +28,7 @@ module Hoopl.Dataflow
, dataflowAnalFwdBlocks, dataflowAnalBwd
, analyzeFwd, analyzeFwdBlocks, analyzeBwd
, changeIf
, changedIf
, joinOutFacts
)
where
......@@ -37,8 +37,37 @@ import BlockId
import Cmm
import Data.Array
import Data.List
import Data.Maybe
import Compiler.Hoopl
-- 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
}
-- TODO(michalt): This wrapper will go away once we refactor the analyze*
-- methods.
......@@ -356,9 +385,9 @@ updateFact fact_join dep_blocks lbl new_fact (todo, fbase)
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)
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
......@@ -381,6 +410,33 @@ 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 O 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
-- -----------------------------------------------------------------------------
-- a Heap of Int
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment