fix bug in mkFactBase when labels are duplicated in argument list
authorNorman Ramsey <nr@cs.tufts.edu>
Tue, 27 Jul 2010 03:36:24 +0000 (23:36 -0400)
committerNorman Ramsey <nr@cs.tufts.edu>
Tue, 27 Jul 2010 03:36:24 +0000 (23:36 -0400)
src/Compiler/Hoopl/Dataflow.hs
src/Compiler/Hoopl/Label.hs
src/Compiler/Hoopl/XUtil.hs

index 0ebcb71..94ff5bd 100644 (file)
@@ -1,7 +1,7 @@
 {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-}
 
 module Compiler.Hoopl.Dataflow
-  ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact
+  ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact, mkFactBase
   , ChangeFlag(..), changeIf
   , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3
   -- * Respecting Fuel
@@ -52,6 +52,20 @@ data ChangeFlag = NoChange | SomeChange deriving (Eq, Ord)
 changeIf :: Bool -> ChangeFlag
 changeIf changed = if changed then SomeChange else NoChange
 
+
+-- | 'mkFactBase' creates a 'FactBase' from a list of ('Label', fact)
+-- pairs.  If the same label appears more than once, the relevant facts
+-- are joined.
+
+mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
+mkFactBase lattice = foldl add mapEmpty
+  where add map (lbl, f) = mapInsert lbl newFact map
+          where newFact = case mapLookup lbl map of
+                            Nothing -> f
+                            Just f' -> snd $ join lbl (OldFact f') (NewFact f)
+                join = fact_join lattice
+
+
 -----------------------------------------------------------------------------
 --             Analyze and rewrite forward: the interface
 -----------------------------------------------------------------------------
@@ -265,8 +279,8 @@ arfGraph pass entries = graph
 -- We know the results _shouldn't change_, but the transfer
 -- functions might, for example, generate some debugging traces.
 joinInFacts :: DataflowLattice f -> FactBase f -> FactBase f
-joinInFacts (DataflowLattice {fact_bot = bot, fact_join = fj}) fb =
-  mkFactBase $ map botJoin $ mapToList fb
+joinInFacts (lattice @ DataflowLattice {fact_bot = bot, fact_join = fj}) fb =
+  mkFactBase lattice $ map botJoin $ mapToList fb
     where botJoin (l, f) = (l, snd $ fj l (OldFact bot) (NewFact f))
 
 forwardBlockList :: (NonLocal n, LabelsPtr entry)
index 10a10d0..2175acd 100644 (file)
@@ -3,7 +3,7 @@ module Compiler.Hoopl.Label
   ( Label
   , freshLabel
   , LabelSet, LabelMap
-  , FactBase, noFacts, mkFactBase, lookupFact
+  , FactBase, noFacts, lookupFact
 
   , uniqueToLbl -- MkGraph and GHC use only
   , lblToUnique -- GHC use only
@@ -100,8 +100,5 @@ type FactBase f = LabelMap f
 noFacts :: FactBase f
 noFacts = mapEmpty
 
-mkFactBase :: [(Label, f)] -> FactBase f
-mkFactBase = mapFromList
-
 lookupFact :: Label -> FactBase f -> Maybe f
 lookupFact = mapLookup
index 52238c6..defdbf0 100644 (file)
@@ -119,19 +119,23 @@ firstXfer xfer n fb = xfer n $ fromJust $ lookupFact (entryLabel n) fb
 -- | This utility function handles a common case in which a transfer function
 -- produces a single fact out of a last node, which is then distributed
 -- over the outgoing edges.
-distributeXfer :: NonLocal n => (n O C -> f -> f) -> (n O C -> f -> FactBase f)
-distributeXfer xfer n f = mkFactBase [ (l, xfer n f) | l <- successors n ]
+distributeXfer :: NonLocal n
+               => DataflowLattice f -> (n O C -> f -> f) -> (n O C -> f -> FactBase f)
+distributeXfer lattice xfer n f =
+    mkFactBase lattice [ (l, xfer n f) | l <- successors n ]
 
 -- | This utility function handles a common case in which a transfer function
 -- for a last node takes the incoming fact unchanged and simply distributes
 -- that fact over the outgoing edges.
 distributeFact :: NonLocal n => n O C -> f -> FactBase f
-distributeFact n f = mkFactBase [ (l, f) | l <- successors n ]
+distributeFact n f = mapFromList [ (l, f) | l <- successors n ]
+   -- because the same fact goes out on every edge,
+   -- there's no need for 'mkFactBase' here.
 
 -- | This utility function handles a common case in which a backward transfer
 -- function takes the incoming fact unchanged and tags it with the node's label.
 distributeFactBwd :: NonLocal n => n C O -> f -> FactBase f
-distributeFactBwd n f = mkFactBase [ (entryLabel n, f) ]
+distributeFactBwd n f = mapSingleton (entryLabel n) f
 
 -- | List of (unlabelled) facts from the successors of a last node
 successorFacts :: NonLocal n => n O C -> FactBase f -> [f]