Abstracting collections of Uniques and Labels.
authorMilan Straka <fox@ucw.cz>
Sun, 2 May 2010 17:13:21 +0000 (18:13 +0100)
committerMilan Straka <fox@ucw.cz>
Sun, 2 May 2010 17:13:21 +0000 (18:13 +0100)
Sets and Maps of Uniques and Labels are instances of classes
IsSet and IsMap defined in Compiler.Hoopl.Collections.
Also the representation of Labels has changed.

16 files changed:
src/Compiler/Hoopl.hs
src/Compiler/Hoopl/Collections.hs [new file with mode: 0644]
src/Compiler/Hoopl/Combinators.hs
src/Compiler/Hoopl/Dataflow.hs
src/Compiler/Hoopl/GHC.hs
src/Compiler/Hoopl/Graph.hs
src/Compiler/Hoopl/GraphUtil.hs
src/Compiler/Hoopl/Label.hs
src/Compiler/Hoopl/MkGraph.hs
src/Compiler/Hoopl/Passes/Dominator.hs
src/Compiler/Hoopl/Show.hs
src/Compiler/Hoopl/Unique.hs
src/Compiler/Hoopl/Util.hs
src/Compiler/Hoopl/XUtil.hs
src/hoopl.cabal
testing/Live.hs

index 0e08ad3..adca9a7 100644 (file)
@@ -2,6 +2,7 @@ module Compiler.Hoopl
   ( module Compiler.Hoopl.Graph
   , module Compiler.Hoopl.MkGraph
   , module Compiler.Hoopl.XUtil
+  , module Compiler.Hoopl.Collections
   , module Compiler.Hoopl.Dataflow
   , module Compiler.Hoopl.Label
   , module Compiler.Hoopl.Pointed
@@ -14,6 +15,7 @@ module Compiler.Hoopl
   )
 where
 
+import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Combinators
 import Compiler.Hoopl.Dataflow
 import Compiler.Hoopl.Debug
@@ -23,10 +25,10 @@ import Compiler.Hoopl.Graph hiding
    , BCat, BHead, BTail, BClosed -- OK to expose BFirst, BMiddle, BLast
    )
 import Compiler.Hoopl.Graph (Body)
-import Compiler.Hoopl.Label hiding (lblOfUniq, uniqOfLbl)
+import Compiler.Hoopl.Label hiding (uniqueToLbl, lblToUnique)
 import Compiler.Hoopl.MkGraph
 import Compiler.Hoopl.Pointed
 import Compiler.Hoopl.Show
 import Compiler.Hoopl.Util
-import Compiler.Hoopl.Unique hiding (intOfUniq, uniqOfInt)
+import Compiler.Hoopl.Unique hiding (uniqueToInt)
 import Compiler.Hoopl.XUtil
diff --git a/src/Compiler/Hoopl/Collections.hs b/src/Compiler/Hoopl/Collections.hs
new file mode 100644 (file)
index 0000000..5c42826
--- /dev/null
@@ -0,0 +1,83 @@
+{- Baseclasses for Map-like and Set-like collections inspired by containers. -}
+
+{-# LANGUAGE TypeFamilies #-}
+module Compiler.Hoopl.Collections ( IsSet(..)
+                                  , IsMap(..)
+                                  ) where
+
+import Data.List (foldl', foldl1')
+
+class IsSet set where
+  type KeySet set
+
+  nullSet :: set -> Bool
+  sizeSet :: set -> Int
+  memberSet :: KeySet set -> set -> Bool
+
+  emptySet :: set
+  singletonSet :: KeySet set -> set
+  insertSet :: KeySet set -> set -> set
+  deleteSet :: KeySet set -> set -> set
+
+  unionSet :: set -> set -> set
+  differenceSet :: set -> set -> set
+  intersectionSet :: set -> set -> set
+  isSubsetOfSet :: set -> set -> Bool
+
+  foldSet :: (KeySet set -> b -> b) -> b -> set -> b
+
+  elemsSet :: set -> [KeySet set]
+  fromListSet :: [KeySet set] -> set
+
+  -- and some derived functions
+  insertListSet :: [KeySet set] -> set -> set
+  insertListSet keys set = foldl' (flip insertSet) set keys
+
+  deleteListSet :: [KeySet set] -> set -> set
+  deleteListSet keys set = foldl' (flip deleteSet) set keys
+
+  unionsSet :: [set] -> set
+  unionsSet [] = emptySet
+  unionsSet sets = foldl1' unionSet sets
+
+
+class IsMap map where
+  type KeyMap map
+
+  nullMap :: map a -> Bool
+  sizeMap :: map a -> Int
+  memberMap :: KeyMap map -> map a -> Bool
+  lookupMap :: KeyMap map -> map a -> Maybe a
+  findWithDefaultMap :: a -> KeyMap map -> map a -> a
+
+  emptyMap :: map a
+  singletonMap :: KeyMap map -> a -> map a
+  insertMap :: KeyMap map -> a -> map a -> map a
+  deleteMap :: KeyMap map -> map a -> map a
+
+  unionMap :: map a -> map a -> map a
+  unionWithKeyMap :: (KeyMap map -> a -> a -> a) -> map a -> map a -> map a
+  differenceMap :: map a -> map a -> map a
+  intersectionMap :: map a -> map a -> map a
+  isSubmapOfMap :: Eq a => map a -> map a -> Bool
+
+  mapMap :: (a -> b) -> map a -> map b
+  mapWithKeyMap :: (KeyMap map -> a -> b) -> map a -> map b
+  foldMap :: (a -> b -> b) -> b -> map a -> b
+  foldWithKeyMap :: (KeyMap map -> a -> b -> b) -> b -> map a -> b
+
+  elemsMap :: map a -> [a]
+  keysMap :: map a -> [KeyMap map]
+  toListMap :: map a -> [(KeyMap map, a)]
+  fromListMap :: [(KeyMap map, a)] -> map a
+
+  -- and some derived functions
+  insertListMap :: [(KeyMap map, a)] -> map a -> map a
+  insertListMap assocs map = foldl' (flip (uncurry insertMap)) map assocs
+
+  deleteListMap :: [KeyMap map] -> map a -> map a
+  deleteListMap keys map = foldl' (flip deleteMap) map keys
+
+  unionsMap :: [map a] -> map a
+  unionsMap [] = emptyMap
+  unionsMap maps = foldl1' unionMap maps
index ddbc150..c7bfed3 100644 (file)
@@ -14,6 +14,7 @@ where
 import Data.Function
 import Data.Maybe
 
+import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Dataflow
 import Compiler.Hoopl.Graph (C, O)
 import Compiler.Hoopl.Label
@@ -175,10 +176,10 @@ productFwd pass1 pass2 = FwdPass lattice transfer rewrite
     transfer = mkFTransfer (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)
       where
         tf  t1 t2 n (f1, f2) = (t1 n f1, t2 n f2)
-        tfb t1 t2 n (f1, f2) = mapWithLFactBase withfb2 fb1
+        tfb t1 t2 n (f1, f2) = mapWithKeyMap withfb2 fb1
           where fb1 = t1 n f1
                 fb2 = t2 n f2
-                withfb2 l f = (f, fromMaybe bot2 $ lookupFact fb2 l)
+                withfb2 l f = (f, fromMaybe bot2 $ lookupFact l fb2)
                 bot2 = fact_bot (fp_lattice pass2)
         (tf1, tm1, tl1) = getFTransfers (fp_transfer pass1)
         (tf2, tm2, tl2) = getFTransfers (fp_transfer pass2)
@@ -197,13 +198,13 @@ productBwd pass1 pass2 = BwdPass lattice transfer rewrite
     transfer = mkBTransfer (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)
       where
         tf  t1 t2 n (f1, f2) = (t1 n f1, t2 n f2)
-        tfb t1 t2 n fb = (t1 n $ mapFactBase fst fb, t2 n $ mapFactBase snd fb)
+        tfb t1 t2 n fb = (t1 n $ mapMap fst fb, t2 n $ mapMap snd fb)
         (tf1, tm1, tl1) = getBTransfers (bp_transfer pass1)
         (tf2, tm2, tl2) = getBTransfers (bp_transfer pass2)
     rewrite = liftRW (bp_rewrite pass1) fst `thenBwdRw` liftRW (bp_rewrite pass2) snd
       where
         liftRW :: forall f1 . BwdRewrite m n f1 -> ((f, f') -> f1) -> BwdRewrite m n (f, f')
-        liftRW rws proj = mkBRewrite (lift proj f) (lift proj m) (lift (mapFactBase proj) l)
+        liftRW rws proj = mkBRewrite (lift proj f) (lift proj m) (lift (mapMap proj) l)
           where 
             lift proj' rw n f =
               case rw n (proj' f) of
index 66133ac..51b4f01 100644 (file)
@@ -67,6 +67,7 @@ where
 
 import Data.Maybe
 
+import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Fuel
 import Compiler.Hoopl.Graph
 import Compiler.Hoopl.MkGraph
@@ -243,7 +244,7 @@ arfGraph pass entries = graph
          => (thing C x ->        f -> m (RG f n C x, Fact x f))
          -> (thing C x -> Fact C f -> m (RG f n C x, Fact x f))
     arfx arf thing fb = 
-      arf thing $ fromJust $ lookupFact (joinInFacts lattice fb) $ entryLabel thing
+      arf thing $ fromJust $ lookupFact (entryLabel thing) $ joinInFacts lattice fb
      where lattice = fp_lattice pass
      -- joinInFacts adds debugging information
 
@@ -256,7 +257,7 @@ arfGraph pass entries = graph
         forwardBlockList entries blocks
       where
         do_block b f = do (g, fb) <- block b $ lookupF pass (entryLabel b) f
-                          return (g, factBaseList fb)
+                          return (g, toListMap fb)
 
 
 
@@ -265,7 +266,7 @@ arfGraph pass entries = graph
 -- functions might, for example, generate some debugging traces.
 joinInFacts :: DataflowLattice f -> FactBase f -> FactBase f
 joinInFacts (DataflowLattice {fact_bot = bot, fact_extend = fe}) fb =
-  mkFactBase $ map botJoin $ factBaseList fb
+  mkFactBase $ map botJoin $ toListMap fb
     where botJoin (l, f) = (l, snd $ fe l (OldFact bot) (NewFact f))
 
 forwardBlockList :: (Edges n, LabelsPtr entry)
@@ -464,16 +465,16 @@ updateFact :: DataflowLattice f -> LabelSet -> (Label, f)
            -> (ChangeFlag, FactBase f)
 -- See Note [TxFactBase change flag]
 updateFact lat lbls (lbl, new_fact) (cha, fbase)
-  | NoChange <- cha2        = (cha,        fbase)
-  | lbl `elemLabelSet` lbls = (SomeChange, new_fbase)
-  | otherwise               = (cha,        new_fbase)
+  | NoChange <- cha2     = (cha,        fbase)
+  | lbl `memberSet` lbls = (SomeChange, new_fbase)
+  | otherwise            = (cha,        new_fbase)
   where
     (cha2, res_fact) -- Note [Unreachable blocks]
-       = case lookupFact fbase lbl of
+       = case lookupFact lbl fbase of
            Nothing -> (SomeChange, snd $ join $ fact_bot lat)  -- Note [Unreachable blocks]
            Just old_fact -> join old_fact
          where join old_fact = fact_extend lat lbl (OldFact old_fact) (NewFact new_fact)
-    new_fbase = extendFactBase fbase lbl res_fact
+    new_fbase = insertMap lbl res_fact fbase
 
 fixpoint :: forall m block n f. (FuelMonad m, Edges n, Edges (block n))
          => Bool       -- Going forwards?
@@ -486,7 +487,7 @@ fixpoint is_fwd lat do_block init_fbase untagged_blocks
   = do { fuel <- getFuel  
        ; tx_fb <- loop fuel init_fbase
        ; return (tfb_rg tx_fb, 
-                 tfb_fbase tx_fb `delFromFactBase` map fst blocks) }
+                 map (fst . fst) blocks `deleteListMap` tfb_fbase tx_fb ) }
             -- The successors of the Graph are the the Labels for which
             -- we have facts, that are *not* in the blocks of the graph
   where
@@ -503,13 +504,13 @@ fixpoint is_fwd lat do_block init_fbase untagged_blocks
              -> TxFactBase n f -> m (TxFactBase n f)
     tx_block lbl blk deps tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls
                                       , tfb_rg = blks, tfb_cha = cha })
-      | is_fwd && not (lbl `elemFactBase` fbase)
-      = return tx_fb {tfb_lbls = lbls `unionLabelSet` mkLabelSet deps} -- Note [Unreachable blocks]
+      | is_fwd && not (lbl `memberMap` fbase)
+      = return tx_fb {tfb_lbls = lbls `unionSet` fromListSet deps}     -- Note [Unreachable blocks]
       | otherwise
       = do { (rg, out_facts) <- do_block blk fbase
            ; let (cha',fbase') 
                    = foldr (updateFact lat lbls) (cha,fbase) out_facts
-                 lbls' = lbls `unionLabelSet` mkLabelSet deps
+                 lbls' = lbls `unionSet` fromListSet deps
            ; return (TxFB { tfb_lbls  = lbls'
                           , tfb_rg    = rg `rgCat` blks
                           , tfb_fbase = fbase', tfb_cha = cha' }) }
@@ -519,7 +520,7 @@ fixpoint is_fwd lat do_block init_fbase untagged_blocks
       = do { let init_tx_fb = TxFB { tfb_fbase = fbase
                                    , tfb_cha   = NoChange
                                    , tfb_rg    = rgnilC
-                                   , tfb_lbls  = emptyLabelSet }
+                                   , tfb_lbls  = emptySet }
            ; tx_fb <- tx_blocks blocks init_tx_fb
            ; case tfb_cha tx_fb of
                NoChange   -> return tx_fb
@@ -592,13 +593,13 @@ normalizeGraph g = (graphMapBlocks dropFact g, facts g)
           facts :: RG f n e x -> FactBase f
           facts GNil = noFacts
           facts (GUnit _) = noFacts
-          facts (GMany _ body exit) = bodyFacts body `unionFactBase` exitFacts exit
+          facts (GMany _ body exit) = bodyFacts body `unionMap` exitFacts exit
           exitFacts :: MaybeO x (FBlock f n C O) -> FactBase f
           exitFacts NothingO = noFacts
           exitFacts (JustO (FBlock f b)) = mkFactBase [(entryLabel b, f)]
           bodyFacts :: Body' (FBlock f) n -> FactBase f
-          bodyFacts (Body body) = foldLabelMap f noFacts body
-            where f (FBlock f b) fb = extendFactBase fb (entryLabel b) f
+          bodyFacts (Body body) = foldMap f noFacts body
+            where f (FBlock f b) fb = insertMap (entryLabel b) f fb
 
 --- implementation of the constructors (boring)
 
@@ -671,5 +672,5 @@ lookupF :: FwdPass m n f -> Label -> FactBase f -> f
 lookupF = getFact . fp_lattice
 
 getFact  :: DataflowLattice f -> Label -> FactBase f -> f
-getFact lat l fb = case lookupFact fb l of Just  f -> f
+getFact lat l fb = case lookupFact l fb of Just  f -> f
                                            Nothing -> fact_bot lat
index 239fbc8..4696b7d 100644 (file)
@@ -1,7 +1,7 @@
 {- Exposing some internals to GHC -}
 module Compiler.Hoopl.GHC
-  ( lblOfUniq, uniqOfLbl
-  , intOfUniq
+  ( uniqueToInt
+  , uniqueToLbl, lblToUnique
   )
 where
 
index 319d53e..e50b041 100644 (file)
@@ -8,6 +8,7 @@ module Compiler.Hoopl.Graph
   )
 where
 
+import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Label
 
 -----------------------------------------------------------------------------
@@ -98,10 +99,10 @@ instance Edges n => Edges (Block n) where
 
 ------------------------------
 emptyBody :: Body' block n
-emptyBody = Body emptyLabelMap
+emptyBody = Body emptyMap
 
 addBlock :: Edges (block n) => block n C C -> Body' block n -> Body' block n
-addBlock b (Body body) = Body (extendLabelMap body (entryLabel b) b)
+addBlock b (Body body) = Body (insertMap (entryLabel b) b body)
 
 bodyList :: Edges (block n) => Body' block n -> [(Label,block n C C)]
-bodyList (Body body) = labelMapList body
+bodyList (Body body) = toListMap body
index b8499a9..79f6e5f 100644 (file)
@@ -9,8 +9,8 @@ module Compiler.Hoopl.GraphUtil
 
 where
 
+import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Graph
-import Compiler.Hoopl.Label
 
 bodyGraph :: Body n -> Graph n C C
 bodyGraph b = GMany NothingO b NothingO
@@ -32,11 +32,11 @@ splice bcat = sp
         sp (GMany e bs (JustO x)) (GUnit b2) = GMany e bs (JustO (x `bcat` b2))
 
         sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) (Body b2) x2)
-          = GMany e1 (Body $ unionLabelMap b1 b2) x2
+          = GMany e1 (Body $ unionMap b1 b2) x2
           where (Body b1) = addBlock (x1 `bcat` e2) bs1
 
         sp (GMany e1 (Body b1) NothingO) (GMany NothingO (Body b2) x2)
-           = GMany e1 (Body $ unionLabelMap b1 b2) x2
+           = GMany e1 (Body $ unionMap b1 b2) x2
 
         sp _ _ = error "bogus GADT match failure"
 
index 63da3e9..acebd7d 100644 (file)
+{-# LANGUAGE TypeFamilies #-}
 module Compiler.Hoopl.Label
   ( Label
   , getLabel
-  , lblOfUniq, uniqOfLbl -- GHC use only
-  , LabelMap, emptyLabelMap, mkLabelMap, lookupLabel, extendLabelMap
-            , delFromLabelMap, unionLabelMap, mapLabelMap, foldLabelMap
-            , elemLabelMap, labelMapLabels, labelMapList
-  , FactBase, noFacts, mkFactBase, unitFact, lookupFact, extendFactBase
-            , delFromFactBase, unionFactBase, mapFactBase, mapWithLFactBase
-            , elemFactBase, factBaseLabels, factBaseList
-  , LabelSet, emptyLabelSet, extendLabelSet, reduceLabelSet
-            , mkLabelSet, elemLabelSet, labelSetElems
-            , minusLabelSet, unionLabelSet, interLabelSet, sizeLabelSet, 
+  , LabelSet, LabelMap
+  , FactBase, noFacts, mkFactBase, lookupFact
+
+  , uniqueToLbl -- MkGraph and GHC use only
+  , lblToUnique -- GHC use only
   )
 
 where
 
+import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Unique
 
-import qualified Data.IntMap as M
-import qualified Data.IntSet as S
+-----------------------------------------------------------------------------
+--             Label
+-----------------------------------------------------------------------------
 
-newtype Label = Label { unLabel :: Int } -- XXX this should be Unique
+newtype Label = Label { lblToUnique :: Unique }
   deriving (Eq, Ord)
 
-lblOfUniq :: Unique -> Label
-lblOfUniq = Label . intOfUniq
-
-uniqOfLbl :: Label -> Unique
-uniqOfLbl = uniqOfInt . unLabel
+uniqueToLbl :: Unique -> Label
+uniqueToLbl = Label
 
 instance Show Label where
   show (Label n) = "L" ++ show n
 
 getLabel :: HooplMonad m => m Label
-getLabel = do { u <- freshUnique; return $ Label $ intOfUniq u }
+getLabel = freshUnique >>= return . uniqueToLbl
 
 -----------------------------------------------------------------------------
---             Label, FactBase, LabelSet
------------------------------------------------------------------------------
-
-
-----------------------
-type FactBase a = M.IntMap a
-
-mapFst :: (a->b) -> (a, c) -> (b, c)
-mapFst f (a, c) = (f a, c)
-
-noFacts :: FactBase f
-noFacts = M.empty
-
-mkFactBase :: [(Label, f)] -> FactBase f
-mkFactBase prs = M.fromList $ map (mapFst unLabel) prs
-
-unitFact :: Label -> FactBase f -> FactBase f
--- Restrict a fact base to a single fact
-unitFact (Label l) fb = case M.lookup l fb of
-                  Just f  -> M.singleton l f
-                  Nothing -> M.empty
-
-lookupFact :: FactBase f -> Label -> Maybe f
-lookupFact env (Label blk_id) = M.lookup blk_id env
-
-extendFactBase :: FactBase f -> Label -> f -> FactBase f
-extendFactBase env (Label blk_id) f = M.insert blk_id f env
-
-unionFactBase :: FactBase f -> FactBase f -> FactBase f
-unionFactBase = M.union
+-- LabelSet
 
-mapFactBase :: (f -> f') -> FactBase f -> FactBase f'
-mapFactBase = M.map
+newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show)
 
-mapWithLFactBase :: (Label -> f -> f') -> FactBase f -> FactBase f'
-mapWithLFactBase f = M.mapWithKey f'
-  where f' l = f (Label l)
+instance IsSet LabelSet where
+  type KeySet LabelSet = Label
 
-elemFactBase :: Label -> FactBase f -> Bool
-elemFactBase (Label l) = M.member l
+  nullSet (LS s) = nullSet s
+  sizeSet (LS s) = sizeSet s
+  memberSet (Label k) (LS s) = memberSet k s
 
-factBaseLabels :: FactBase f -> [Label]
-factBaseLabels = map Label . M.keys
+  emptySet = LS emptySet
+  singletonSet (Label k) = LS (singletonSet k)
+  insertSet (Label k) (LS s) = LS (insertSet k s)
+  deleteSet (Label k) (LS s) = LS (deleteSet k s)
 
-factBaseList :: FactBase f -> [(Label, f)]
-factBaseList = map (mapFst Label) . M.toList 
+  unionSet (LS x) (LS y) = LS (unionSet x y)
+  differenceSet (LS x) (LS y) = LS (differenceSet x y)
+  intersectionSet (LS x) (LS y) = LS (intersectionSet x y)
+  isSubsetOfSet (LS x) (LS y) = isSubsetOfSet x y
 
-delFromFactBase :: FactBase f -> [(Label,a)] -> FactBase f
-delFromFactBase fb blks = foldr (M.delete . unLabel . fst) fb blks
+  foldSet k z (LS s) = foldSet (k . uniqueToLbl) z s
 
-----------------------------------------------------------------
-type LabelMap a = M.IntMap a
+  elemsSet (LS s) = map uniqueToLbl (elemsSet s)
+  fromListSet ks = LS (fromListSet (map lblToUnique ks))
 
-emptyLabelMap :: LabelMap f
-emptyLabelMap = M.empty
-
-mkLabelMap :: [(Label, f)] -> LabelMap f
-mkLabelMap = mkFactBase
-
-lookupLabel :: LabelMap f -> Label -> Maybe f
-lookupLabel = lookupFact
-
-extendLabelMap :: LabelMap f -> Label -> f -> LabelMap f
-extendLabelMap = extendFactBase
-
-unionLabelMap :: LabelMap f -> LabelMap f -> LabelMap f
-unionLabelMap = M.union
-
-mapLabelMap :: (f -> f') -> LabelMap f -> LabelMap f'
-mapLabelMap = M.map
-
-foldLabelMap :: (f -> z -> z) -> z -> LabelMap f -> z
-foldLabelMap = M.fold
-
-elemLabelMap :: Label -> LabelMap f -> Bool
-elemLabelMap = elemFactBase
-
-labelMapLabels :: LabelMap f -> [Label]
-labelMapLabels = factBaseLabels
-
-labelMapList :: LabelMap f -> [(Label, f)]
-labelMapList = factBaseList
-
-delFromLabelMap :: LabelMap f -> [(Label,a)] -> LabelMap f
-delFromLabelMap = delFromFactBase
-
-----------------------
-newtype LabelSet = LS { unLS :: S.IntSet }
-
-emptyLabelSet :: LabelSet
-emptyLabelSet = LS S.empty
+-----------------------------------------------------------------------------
+-- LabelMap
 
-extendLabelSet :: LabelSet -> Label -> LabelSet
-extendLabelSet lbls (Label bid) = LS $ S.insert bid $ unLS lbls
+newtype LabelMap v = LM (UniqueMap v) deriving (Eq, Ord, Show)
 
-reduceLabelSet :: LabelSet -> Label -> LabelSet
-reduceLabelSet lbls (Label bid) = LS $ S.delete bid $ unLS lbls
+instance IsMap LabelMap where
+  type KeyMap LabelMap = Label
 
-elemLabelSet :: Label -> LabelSet -> Bool
-elemLabelSet (Label bid) lbls = S.member bid (unLS lbls)
+  nullMap (LM m) = nullMap m
+  sizeMap (LM m) = sizeMap m
+  memberMap (Label k) (LM m) = memberMap k m
+  lookupMap (Label k) (LM m) = lookupMap k m
+  findWithDefaultMap def (Label k) (LM m) = findWithDefaultMap def k m
 
-labelSetElems :: LabelSet -> [Label]
-labelSetElems = map Label . S.toList . unLS
+  emptyMap = LM emptyMap
+  singletonMap (Label k) v = LM (singletonMap k v)
+  insertMap (Label k) v (LM m) = LM (insertMap k v m)
+  deleteMap (Label k) (LM m) = LM (deleteMap k m)
 
-set2 :: (S.IntSet -> S.IntSet -> S.IntSet)
-     -> (LabelSet -> LabelSet -> LabelSet)
-set2 f (LS ls) (LS ls') = LS (f ls ls')
+  unionMap (LM x) (LM y) = LM (unionMap x y)
+  unionWithKeyMap f (LM x) (LM y) = LM (unionWithKeyMap (f . uniqueToLbl) x y)
+  differenceMap (LM x) (LM y) = LM (differenceMap x y)
+  intersectionMap (LM x) (LM y) = LM (intersectionMap x y)
+  isSubmapOfMap (LM x) (LM y) = isSubmapOfMap x y
 
-minusLabelSet :: LabelSet -> LabelSet -> LabelSet
-minusLabelSet = set2 S.difference
+  mapMap f (LM m) = LM (mapMap f m)
+  mapWithKeyMap f (LM m) = LM (mapWithKeyMap (f . uniqueToLbl) m)
+  foldMap k z (LM m) = foldMap k z m
+  foldWithKeyMap k z (LM m) = foldWithKeyMap (k . uniqueToLbl) z m
 
-unionLabelSet :: LabelSet -> LabelSet -> LabelSet
-unionLabelSet = set2 S.union
+  elemsMap (LM m) = elemsMap m
+  keysMap (LM m) = map uniqueToLbl (keysMap m)
+  toListMap (LM m) = [(uniqueToLbl k, v) | (k, v) <- toListMap m]
+  fromListMap assocs = LM (fromListMap [(lblToUnique k, v) | (k, v) <- assocs])
 
-interLabelSet :: LabelSet -> LabelSet -> LabelSet
-interLabelSet = set2 S.intersection
+-----------------------------------------------------------------------------
+-- FactBase
 
-sizeLabelSet :: LabelSet -> Int
-sizeLabelSet = S.size . unLS
+type FactBase f = LabelMap f
 
-mkLabelSet :: [Label] -> LabelSet
-mkLabelSet = LS . S.fromList . map unLabel
+noFacts :: FactBase f
+noFacts = emptyMap
 
+mkFactBase :: [(Label, f)] -> FactBase f
+mkFactBase = fromListMap
 
+lookupFact :: Label -> FactBase f -> Maybe f
+lookupFact = lookupMap
index bb92526..5dc0ef0 100644 (file)
@@ -10,10 +10,10 @@ module Compiler.Hoopl.MkGraph
     )
 where
 
-import Compiler.Hoopl.Label (Label, lblOfUniq)
+import Compiler.Hoopl.Collections
+import Compiler.Hoopl.Label (Label, uniqueToLbl)
 import Compiler.Hoopl.Graph
 import qualified Compiler.Hoopl.GraphUtil as U
-import Compiler.Hoopl.Label (unionLabelMap)
 import Compiler.Hoopl.Unique
 import Control.Monad (liftM2)
 
@@ -144,7 +144,7 @@ instance Uniques Unique where
   withFresh f = A $ freshUnique >>= (graphOfAGraph . f)
 
 instance Uniques Label where
-  withFresh f = A $ freshUnique >>= (graphOfAGraph . f . lblOfUniq)
+  withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl)
 
 -- | Lifts binary 'Graph' functions into 'AGraph' functions.
 liftA2 :: Monad m
@@ -160,7 +160,7 @@ addBlocks (A g) (A blocks) = A $ g >>= \g -> blocks >>= add g
   where add :: (HooplMonad m, HooplNode n)
             => Graph n e x -> Graph n C C -> m (Graph n e x)
         add (GMany e (Body body) x) (GMany NothingO (Body body') NothingO) =
-          return $ GMany e (Body $ unionLabelMap body body') x
+          return $ GMany e (Body $ unionMap body body') x
         add g@GNil      blocks = spliceOO g blocks
         add g@(GUnit _) blocks = spliceOO g blocks
         spliceOO :: (HooplNode n, HooplMonad m)
index 6a13405..fba9fea 100644 (file)
@@ -84,12 +84,12 @@ tree facts = Dominates Entry $ merge $ map reverse $ map mkList facts
   where merge lists = mapTree $ children $ filter (not . null) lists
         children = foldl addList noFacts
         addList :: FactBase [[Label]] -> [Label] -> FactBase [[Label]]
-        addList map (x:xs) = extendFactBase map x (xs:existing)
-            where existing = fromMaybe [] $ lookupFact map x
+        addList map (x:xs) = insertMap x (xs:existing) map
+            where existing = fromMaybe [] $ lookupFact x map
         addList _ [] = error "this can't happen"
         mapTree :: FactBase [[Label]] -> [DominatorTree]
         mapTree map = [Dominates (Labelled x) (merge lists) |
-                                                    (x, lists) <- factBaseList map]
+                                                    (x, lists) <- toListMap map]
         mkList (l, doms) = l : domPath doms
 
 
index 558d959..21495bb 100644 (file)
@@ -5,6 +5,7 @@ module Compiler.Hoopl.Show
   )
 where
 
+import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Graph
 import Compiler.Hoopl.Label
 
@@ -37,4 +38,4 @@ open _ NothingO  = ""
 open p (JustO n) = p n
 
 showFactBase :: Show f => FactBase f -> String
-showFactBase = show . factBaseList
+showFactBase = show . toListMap
index c8bfd39..cb901b9 100644 (file)
+{-# LANGUAGE TypeFamilies #-}
 module Compiler.Hoopl.Unique
-  ( Unique
+  ( Unique, mkUnique
+  , UniqueSet, UniqueMap
   , HooplMonad(..)
   , SimpleHooplMonad, runSimpleHooplMonad
   , HooplMonadT, runHooplMonadT
 
-  , intOfUniq, uniqOfInt -- exposed through GHC module only!
+  , uniqueToInt -- exposed through GHC module only!
   )
 
 where
 
+import Compiler.Hoopl.Collections
+
+import qualified Data.IntMap as M
+import qualified Data.IntSet as S
+
 -----------------------------------------------------------------------------
 --             Unique
 -----------------------------------------------------------------------------
 
-data Unique = Unique { intOfUniq ::  {-# UNPACK #-} !Int }
+data Unique = Unique { uniqueToInt ::  {-# UNPACK #-} !Int }
   deriving (Eq, Ord)
 
-uniqOfInt :: Int -> Unique
-uniqOfInt = Unique
+mkUnique :: Int -> Unique
+mkUnique = Unique
 
 instance Show Unique where
   show (Unique n) = show n
 
-class Monad m => HooplMonad m where
-  freshUnique :: m Unique
+-----------------------------------------------------------------------------
+-- UniqueSet
+
+newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show)
+
+instance IsSet UniqueSet where
+  type KeySet UniqueSet = Unique
+
+  nullSet (US s) = S.null s
+  sizeSet (US s) = S.size s
+  memberSet (Unique k) (US s) = S.member k s
+
+  emptySet = US S.empty
+  singletonSet (Unique k) = US (S.singleton k)
+  insertSet (Unique k) (US s) = US (S.insert k s)
+  deleteSet (Unique k) (US s) = US (S.delete k s)
+
+  unionSet (US x) (US y) = US (S.union x y)
+  differenceSet (US x) (US y) = US (S.difference x y)
+  intersectionSet (US x) (US y) = US (S.intersection x y)
+  isSubsetOfSet (US x) (US y) = S.isSubsetOf x y
+
+  foldSet k z (US s) = S.fold (k . mkUnique) z s
+
+  elemsSet (US s) = map mkUnique (S.elems s)
+  fromListSet ks = US (S.fromList (map uniqueToInt ks))
+
+-----------------------------------------------------------------------------
+-- UniqueMap
+
+newtype UniqueMap v = UM (M.IntMap v) deriving (Eq, Ord, Show)
+
+instance IsMap UniqueMap where
+  type KeyMap UniqueMap = Unique
+
+  nullMap (UM m) = M.null m
+  sizeMap (UM m) = M.size m
+  memberMap (Unique k) (UM m) = M.member k m
+  lookupMap (Unique k) (UM m) = M.lookup k m
+  findWithDefaultMap def (Unique k) (UM m) = M.findWithDefault def k m
+
+  emptyMap = UM M.empty
+  singletonMap (Unique k) v = UM (M.singleton k v)
+  insertMap (Unique k) v (UM m) = UM (M.insert k v m)
+  deleteMap (Unique k) (UM m) = UM (M.delete k m)
+
+  unionMap (UM x) (UM y) = UM (M.union x y)
+  unionWithKeyMap f (UM x) (UM y) = UM (M.unionWithKey (f . mkUnique) x y)
+  differenceMap (UM x) (UM y) = UM (M.difference x y)
+  intersectionMap (UM x) (UM y) = UM (M.intersection x y)
+  isSubmapOfMap (UM x) (UM y) = M.isSubmapOf x y
+
+  mapMap f (UM m) = UM (M.map f m)
+  mapWithKeyMap f (UM m) = UM (M.mapWithKey (f . mkUnique) m)
+  foldMap k z (UM m) = M.fold k z m
+  foldWithKeyMap k z (UM m) = M.foldWithKey (k . mkUnique) z m
+
+  elemsMap (UM m) = M.elems m
+  keysMap (UM m) = map mkUnique (M.keys m)
+  toListMap (UM m) = [(mkUnique k, v) | (k, v) <- M.toList m]
+  fromListMap assocs = UM (M.fromList [(uniqueToInt k, v) | (k, v) <- assocs])
 
 ----------------------------------------------------------------
+-- Monads
+
+class Monad m => HooplMonad m where
+  freshUnique :: m Unique
 
 newtype SimpleHooplMonad a = SHM { unSHM :: [Unique] -> (a, [Unique]) }
 
index 02aaab9..0cd5b4f 100644 (file)
@@ -15,6 +15,7 @@ where
 
 import Control.Monad
 
+import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Graph
 import Compiler.Hoopl.Label
 
@@ -91,7 +92,7 @@ graphMapBlocks f = map
         map (GUnit b) = GUnit (f b)
         map (GMany e b x) = GMany (fmap f e) (bodyMapBlocks f b) (fmap f x)
 
-bodyMapBlocks f (Body body) = Body $ mapLabelMap f body
+bodyMapBlocks f (Body body) = Body $ mapMap f body
 
 
 ----------------------------------------------------------------
@@ -106,7 +107,7 @@ instance LabelsPtr Label where
   targetLabels l = [l]
 
 instance LabelsPtr LabelSet where
-  targetLabels = labelSetElems
+  targetLabels = elemsSet
 
 instance LabelsPtr l => LabelsPtr [l] where
   targetLabels = concatMap targetLabels
@@ -158,7 +159,7 @@ graphDfs :: (Edges (block n))
          -> (Graph' block n O x -> [block n C C])
 graphDfs _     (GNil)    = []
 graphDfs _     (GUnit{}) = []
-graphDfs order (GMany (JustO entry) (Body body) _) = order body entry emptyLabelSet
+graphDfs order (GMany (JustO entry) (Body body) _) = order body entry emptySet
 
 postorder_dfs = graphDfs postorder_dfs_from_except
 preorder_dfs  = graphDfs preorder_dfs_from_except
@@ -170,24 +171,24 @@ postorder_dfs_from_except blocks b visited =
  where
    vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
    vnode block cont acc visited =
-        if elemLabelSet id visited then
+        if memberSet id visited then
             cont acc visited
         else
             let cont' acc visited = cont (block:acc) visited in
-            vchildren (get_children block) cont' acc (extendLabelSet visited id)
+            vchildren (get_children block) cont' acc (insertSet id visited)
       where id = entryLabel block
    vchildren bs cont acc visited = next bs acc visited
       where next children acc visited =
                 case children of []     -> cont acc visited
                                  (b:bs) -> vnode b (next bs) acc visited
    get_children block = foldr add_id [] $ targetLabels block
-   add_id id rst = case lookupFact blocks id of
+   add_id id rst = case lookupFact id blocks of
                       Just b -> b : rst
                       Nothing -> rst
 
 postorder_dfs_from
     :: (Edges block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]
-postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyLabelSet
+postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptySet
 
 
 ----------------------------------------------------------------
@@ -198,8 +199,8 @@ mark   :: Label -> VM ()
 instance Monad VM where
   return a = VM $ \visited -> (a, visited)
   m >>= k  = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v'
-marked l = VM $ \v -> (elemLabelSet l v, v)
-mark   l = VM $ \v -> ((), extendLabelSet v l)
+marked l = VM $ \v -> (memberSet l v, v)
+mark   l = VM $ \v -> ((), insertSet l v)
 
 preorder_dfs_from_except :: forall block e . (Edges block, LabelsPtr e)
                          => LabelMap (block C C) -> e -> LabelSet -> [block C C]
@@ -214,7 +215,7 @@ preorder_dfs_from_except blocks b visited =
                               bs <- children $ get_children b
                               return $ b `cons` bs
         get_children block = foldr add_id [] $ targetLabels block
-        add_id id rst = case lookupFact blocks id of
+        add_id id rst = case lookupFact id blocks of
                           Just b -> b : rst
                           Nothing -> rst
 
@@ -225,28 +226,28 @@ cons a as tail = a : as tail
 ----------------------------------------------------------------
 
 labelsDefined :: forall block n e x . Edges (block n) => Graph' block n e x -> LabelSet
-labelsDefined GNil      = emptyLabelSet
-labelsDefined (GUnit{}) = emptyLabelSet
+labelsDefined GNil      = emptySet
+labelsDefined (GUnit{}) = emptySet
 labelsDefined (GMany _ body x) = foldBodyBlocks addEntry body $ exitLabel x
-  where addEntry block labels = extendLabelSet labels (entryLabel block)
+  where addEntry block labels = insertSet (entryLabel block) labels
         exitLabel :: MaybeO x (block n C O) -> LabelSet
-        exitLabel NothingO = emptyLabelSet
-        exitLabel (JustO b) = mkLabelSet [entryLabel b]
+        exitLabel NothingO = emptySet
+        exitLabel (JustO b) = fromListSet [entryLabel b]
 
 labelsUsed :: forall block n e x. Edges (block n) => Graph' block n e x -> LabelSet
-labelsUsed GNil      = emptyLabelSet
-labelsUsed (GUnit{}) = emptyLabelSet
+labelsUsed GNil      = emptySet
+labelsUsed (GUnit{}) = emptySet
 labelsUsed (GMany e body _) = foldBodyBlocks addTargets body $ entryTargets e
-  where addTargets block labels = foldl extendLabelSet labels (successors block)
+  where addTargets block labels = insertListSet (successors block) labels
         entryTargets :: MaybeO e (block n O C) -> LabelSet
-        entryTargets NothingO = emptyLabelSet
-        entryTargets (JustO b) = addTargets b emptyLabelSet
+        entryTargets NothingO = emptySet
+        entryTargets (JustO b) = addTargets b emptySet
 
 foldBodyBlocks :: (block n C C -> a -> a) -> Body' block n -> a -> a
-foldBodyBlocks f (Body body) z = foldLabelMap f z body
+foldBodyBlocks f (Body body) z = foldMap f z body
 
 externalEntryLabels :: Edges (block n) => Body' block n -> LabelSet
-externalEntryLabels body = defined `minusLabelSet` used
+externalEntryLabels body = defined `differenceSet` used
   where defined = labelsDefined g
         used = labelsUsed g
         g = GMany NothingO body NothingO
index 8b0bdcd..9de9efc 100644 (file)
@@ -16,6 +16,7 @@ where
 
 import Data.Maybe
 
+import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Dataflow
 import Compiler.Hoopl.Fuel
 import Compiler.Hoopl.Graph
@@ -101,7 +102,7 @@ analyzeAndRewriteBwdOx pass g fb = analyzeAndRewriteBwd pass noEntries g fb >>=
 -- interface.
 
 firstXfer :: Edges n => (n C O -> f -> f) -> (n C O -> FactBase f -> f)
-firstXfer xfer n fb = xfer n $ fromJust $ lookupFact fb $ entryLabel n
+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
@@ -122,7 +123,7 @@ distributeFactBwd n f = mkFactBase [ (entryLabel n, f) ]
 
 -- | List of (unlabelled) facts from the successors of a last node
 successorFacts :: Edges n => n O C -> FactBase f -> [f]
-successorFacts n fb = [ f | id <- successors n, let Just f = lookupFact fb id ]
+successorFacts n fb = [ f | id <- successors n, let Just f = lookupFact id fb ]
 
 
 -- | Fold a function over every node in a block, forward or backward.
@@ -184,7 +185,7 @@ foldGraphNodes f = graph
           graph (GUnit b)         = block b
           graph (GMany e b x)     = lift block e . body b . lift block x
           body :: Body n -> a -> a
-          body  (Body bdy)        = \a -> foldLabelMap block a bdy
+          body  (Body bdy)        = \a -> foldMap block a bdy
           lift _ NothingO         = id
           lift f (JustO thing)    = f thing
 
@@ -200,7 +201,7 @@ lookupBlock :: Edges n => Graph n e x -> Label -> BlockResult n x
 lookupBlock (GMany _ _ (JustO exit)) lbl
   | entryLabel exit == lbl = ExitBlock exit
 lookupBlock (GMany _ (Body body)  _) lbl =
-  case lookupLabel body lbl of
+  case lookupMap lbl body of
     Just b  -> BodyBlock b
     Nothing -> NoBlock
 lookupBlock GNil      _ = NoBlock
index c575fc5..c97df19 100644 (file)
@@ -23,6 +23,7 @@ Library
   Other-modules:     Compiler.Hoopl.GraphUtil,
                      -- GraphUtil should *never* be seen by clients.
                      -- The remaining modules are hidden *provisionally*
+                       Compiler.Hoopl.Collections,
                        Compiler.Hoopl.Combinators,
                        Compiler.Hoopl.Dataflow,
                        Compiler.Hoopl.Debug,
index f273cd4..c363d05 100644 (file)
@@ -33,7 +33,7 @@ liveness = mkBTransfer' live
     live n@(Cond _ tl fl)  f = addUses (fact f tl `S.union` fact f fl) n
     live n@(Call vs _ _ l) f = addUses (fact f l `S.difference` S.fromList vs) n
     live n@(Return _)      _ = addUses (fact_bot liveLattice) n
-    fact f l = fromMaybe S.empty $ lookupFact f l
+    fact f l = fromMaybe S.empty $ lookupFact l f
     addUses = fold_EN (fold_EE addVar)
     addVar s (Var v) = S.insert v s
     addVar s _       = s