migrated withFuel into rewrite functions, with pleasant consequences:
authorNorman Ramsey <nr@cs.tufts.edu>
Wed, 16 Jun 2010 18:00:19 +0000 (14:00 -0400)
committerNorman Ramsey <nr@cs.tufts.edu>
Wed, 16 Jun 2010 18:00:19 +0000 (14:00 -0400)
  - Combinators.hs becomes dramatically simpler

  - Dataflow.hs now exports 'wrapper' functions for rewrites.
    These functions must preserve a subtle invariant called "respecting fuel".
    They are exported to the client but deprecated.

The paper is now in some disarray.

12 files changed:
paper/dfopt.tex
src/Compiler/Hoopl.hs
src/Compiler/Hoopl/Combinators.hs
src/Compiler/Hoopl/Dataflow.hs
src/Compiler/Hoopl/Graph.hs
src/Compiler/Hoopl/Wrappers.hs [new file with mode: 0644]
src/Compiler/Hoopl/XUtil.hs
src/hoopl.cabal
testing/ConstProp.hs
testing/Live.hs
testing/Simplify.hs
testing/Test.hs

index 4cecd46..055167e 100644 (file)
@@ -2146,6 +2146,11 @@ exactly analogous and are included in \hoopl.
 
 
 
+\begin{code}
+`withFuel :: FuelMonad m => Maybe a -> m (Maybe a)
+\end{code}
+
+
 as expressed by the
 @FwdRew@ type returned by a @FwdRewrite@ (\figref{api-types}).
 The first component of the @FwdRew@ is the replacement graph, as discussed earlier.
@@ -2482,7 +2487,7 @@ The @node@ function is where we interleave analysis with rewriting:
 node :: forall e x . (ShapeLifter e x, FuelMonad m) 
      => n e x -> f -> m (DG f n e x, Fact x f)
 node n f
- = do { rew <- withFuel =<< frewrite pass n f
+ = do { rew <- frewrite pass n f
       ; case rew of
           Nothing -> return (singletonDG f n,
                              ftransfer pass n f)
@@ -2491,8 +2496,6 @@ node n f
                 f'    = fwdEntryFact n f
             in  arfGraph pass' (fwdEntryLabel n) g f' }
 
-`withFuel :: FuelMonad m => Maybe a -> m (Maybe a)
-
 class ShapeLifter e x where
  singletonDG   :: f -> n e x -> DG f n e x
  fwdEntryFact  :: NonLocal n => n e x -> f -> Fact e f
index 46a00df..18b49d8 100644 (file)
@@ -17,7 +17,9 @@ where
 
 import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Combinators
-import Compiler.Hoopl.Dataflow hiding (FwdRew(..), BwdRew(..), FwdRewrite3, BwdRewrite3)
+import Compiler.Hoopl.Dataflow hiding ( FwdRew(..), BwdRew(..)
+                                      , wrapFR, wrapFR2, wrapBR, wrapBR2
+                                      )
 import Compiler.Hoopl.Debug
 import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel, FuelMonadT)
 import Compiler.Hoopl.Graph hiding 
index 181e4f5..8dc5c10 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables, GADTs #-}
 
 module Compiler.Hoopl.Combinators
   ( thenFwdRw
@@ -11,37 +11,21 @@ module Compiler.Hoopl.Combinators
 where
 
 import Control.Monad
-import Data.Function
 import Data.Maybe
 
 import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Dataflow
 import Compiler.Hoopl.Fuel
-import Compiler.Hoopl.Graph (Graph, C, O)
+import Compiler.Hoopl.Graph (Graph, C, O, Shape(..))
 import Compiler.Hoopl.Label
 
-type BR m n f = BwdRewrite m n f
-
-type FromFwdRw3 m n f a 
-            =  (n C O -> f -> m (Maybe (Graph n C O)))
-            -> (n O O -> f -> m (Maybe (Graph n O O)))
-            -> (n O C -> f -> m (Maybe (Graph n O C)))
-            -> a
-
-----------------------------------------------------------------
--- common operations on triples
-
-apply :: (a -> b, d -> e, g -> h) -> (a, d, g) -> (b, e, h)
-apply (f1, f2, f3) (x1, x2, x3) = (f1 x1, f2 x2, f3 x3)
-
-applyBinary :: (a -> b -> c, d -> e -> f, g -> h -> i)
-            -> (a, d, g) -> (b, e, h) -> (c, f, i)
-applyBinary (f1, f2, f3) (x1, x2, x3) (y1, y2, y3) = (f1 x1 y1, f2 x2 y2, f3 x3 y3)
-
-
 ----------------------------------------------------------------
 
-deepFwdRw3 :: FuelMonad m => FromFwdRw3 m n f (FwdRewrite m n f)
+deepFwdRw3 :: FuelMonad m
+           => (n C O -> f -> m (Maybe (Graph n C O)))
+           -> (n O O -> f -> m (Maybe (Graph n O O)))
+           -> (n O C -> f -> m (Maybe (Graph n O C)))
+           -> (FwdRewrite m n f)
 deepFwdRw :: FuelMonad m
           => (forall e x . n e x -> f -> m (Maybe (Graph n e x))) -> FwdRewrite m n f
 deepFwdRw3 f m l = iterFwdRw $ mkFRewrite3 f m l
@@ -55,8 +39,7 @@ thenFwdRw :: Monad m
           -> FwdRewrite m n f 
           -> FwdRewrite m n f
 -- @ end comb1.tex
-thenFwdRw rw3 rw3' =
-  FwdRewrite3 $ (applyBinary (thenrw, thenrw, thenrw) `on` getFRewrite3) rw3 rw3'
+thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3'
  where
   thenrw rw rw' n f = rw n f >>= fwdRes
      where fwdRes Nothing = rw' n f
@@ -68,49 +51,37 @@ iterFwdRw :: Monad m
           => FwdRewrite m n f 
           -> FwdRewrite m n f
 -- @ end iterf.tex
-iterFwdRw rw3 = FwdRewrite3 . apply (iter, iter, iter) . getFRewrite3 $ rw3
+iterFwdRw rw3 = wrapFR iter rw3
  where
     iter rw n f = liftM (liftM fwdRes) (rw n f)
     fwdRes (FwdRew g rw3a) = 
       FwdRew g (rw3a `thenFwdRw` iterFwdRw rw3)
 
 ----------------------------------------------------------------
-type FromBwdRw3 m n f a 
-            =  (n C O -> f          -> m (Maybe (Graph n C O)))
-            -> (n O O -> f          -> m (Maybe (Graph n O O)))
-            -> (n O C -> FactBase f -> m (Maybe (Graph n O C)))
-            -> a
-
-type BRW  m n f e x = n e x -> Fact x f -> m (Maybe (BwdRew m n f e x))
-type MapBRW2 m n f e x = BRW  m n f e x -> BRW m n f e x -> BRW m n f e x
-
-----------------------------------------------------------------
-
-wrapBRewrites2 :: (forall e x . MapBRW2 m n f e x) -> BR m n f -> BR m n f -> BR m n f
-wrapBRewrites2 map = w2 (map, map, map)
-  where w2 map rw1 rw2 =
-            BwdRewrite3 $ (applyBinary map `on` getBRewrite3) rw1 rw2
-
-----------------------------------------------------------------
 
-deepBwdRw3 :: FuelMonad m => FromBwdRw3 m n f (BwdRewrite m n f)
+deepBwdRw3 :: FuelMonad m
+           => (n C O -> f          -> m (Maybe (Graph n C O)))
+           -> (n O O -> f          -> m (Maybe (Graph n O O)))
+           -> (n O C -> FactBase f -> m (Maybe (Graph n O C)))
+           -> (BwdRewrite m n f)
 deepBwdRw  :: FuelMonad m
-           => (forall e x . n e x -> Fact x f -> m (Maybe (Graph n e x))) -> BwdRewrite m n f
+           => (forall e x . n e x -> Fact x f -> m (Maybe (Graph n e x)))
+           -> BwdRewrite m n f
 deepBwdRw3 f m l = iterBwdRw $ mkBRewrite3 f m l
 deepBwdRw  f = deepBwdRw3 f f f
 
 
 thenBwdRw :: Monad m => BwdRewrite m n f -> BwdRewrite m n f -> BwdRewrite m n f
-thenBwdRw rw1 rw2 = wrapBRewrites2 f rw1 rw2
-  where f rw1 rw2' n f = do
+thenBwdRw rw1 rw2 = wrapBR2 f rw1 rw2
+  where f rw1 rw2' n f = do
           res1 <- rw1 n f
           case res1 of
             Nothing              -> rw2' n f
             Just (BwdRew g rw1a) -> return $ Just $ BwdRew g (rw1a `thenBwdRw` rw2)
 
 iterBwdRw :: Monad m => BwdRewrite m n f -> BwdRewrite m n f
-iterBwdRw rw = BwdRewrite3 . apply (f, f, f) . getBRewrite3 $ rw
-  where f rw' n f = liftM (liftM iterRewrite) (rw' n f)
+iterBwdRw rw = wrapBR f rw
+  where f rw' n f = liftM (liftM iterRewrite) (rw' n f)
         iterRewrite (BwdRew g rw2) = BwdRew g (rw2 `thenBwdRw` iterBwdRw rw)
 
 -- @ start pairf.tex
@@ -132,12 +103,11 @@ pairFwd pass1 pass2 = FwdPass lattice transfer rewrite
                 bot2 = fact_bot (fp_lattice pass2)
         (tf1, tm1, tl1) = getFTransfer3 (fp_transfer pass1)
         (tf2, tm2, tl2) = getFTransfer3 (fp_transfer pass2)
-    rewrite = liftRW (fp_rewrite pass1) fst `thenFwdRw` liftRW (fp_rewrite pass2) snd
+    rewrite = lift fst (fp_rewrite pass1) `thenFwdRw` lift snd (fp_rewrite pass2) 
       where
-        liftRW rws proj = FwdRewrite3 (lift f, lift m, lift l)
-          where lift rw n f = liftM (liftM projRewrite) $ rw n (proj f)
-                projRewrite (FwdRew g rws') = FwdRew g $ liftRW rws' proj
-                (f, m, l) = getFRewrite3 rws
+        lift proj = wrapFR project
+          where project rw = \n pair -> liftM (liftM repair) $ rw n (proj pair)
+                repair (FwdRew g rw') = FwdRew g (lift proj rw')
 
 pairBwd :: forall m n f f' . Monad m => BwdPass m n f -> BwdPass m n f' -> BwdPass m n (f, f')
 pairBwd pass1 pass2 = BwdPass lattice transfer rewrite
@@ -149,13 +119,18 @@ pairBwd pass1 pass2 = BwdPass lattice transfer rewrite
         tfb t1 t2 n fb = (t1 n $ mapMap fst fb, t2 n $ mapMap snd fb)
         (tf1, tm1, tl1) = getBTransfer3 (bp_transfer pass1)
         (tf2, tm2, tl2) = getBTransfer3 (bp_transfer pass2)
-    rewrite = liftRW (bp_rewrite pass1) fst `thenBwdRw` liftRW (bp_rewrite pass2) snd
+    rewrite = lift fst (bp_rewrite pass1) `thenBwdRw` lift snd (bp_rewrite pass2) 
       where
-        liftRW :: forall f1 . BwdRewrite m n f1 -> ((f, f') -> f1) -> BwdRewrite m n (f, f')
-        liftRW rws proj = BwdRewrite3 (lift proj f, lift proj m, lift (mapMap proj) l)
-          where lift proj' rw n f = liftM (liftM projRewrite) $ rw n (proj' f)
-                projRewrite (BwdRew g rws') = BwdRew g $ liftRW rws' proj
-                (f, m, l) = getBRewrite3 rws
+        lift :: forall f1 .
+                ((f, f') -> f1) -> BwdRewrite m n f1 -> BwdRewrite m n (f, f')
+        lift proj = wrapBR project
+            where project :: forall e x . Shape x 
+                      -> (n e x -> Fact x f1 -> m (Maybe (BwdRew m n f1 e x)))
+                      -> (n e x -> Fact x (f,f') -> m (Maybe (BwdRew m n (f,f') e x)))
+                  project Open = \rw n pair -> liftM (liftM repair) $ rw n (proj pair)
+                  project Closed = 
+                       \rw n pair -> liftM (liftM repair) $ rw n (mapMap proj pair)
+                  repair (BwdRew g rw') = BwdRew g (lift proj rw')
 
 pairLattice :: forall f f' . DataflowLattice f -> DataflowLattice f' -> DataflowLattice (f, f')
 pairLattice l1 l2 =
index 6237613..60f9cce 100644 (file)
@@ -3,11 +3,14 @@
 module Compiler.Hoopl.Dataflow
   ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact
   , ChangeFlag(..), changeIf
-  , FwdRewrite(FwdRewrite3) --- temporary??
-  , BwdRewrite(BwdRewrite3) --- temporary??
   , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3
+  -- * Respecting Fuel
+
+  -- $fuel
   , FwdRew(..),  FwdRewrite,  mkFRewrite,  mkFRewrite3,  getFRewrite3, noFwdRewrite
+  , wrapFR, wrapFR2
   , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3
+  , wrapBR, wrapBR2
   , BwdRew(..),  BwdRewrite,  mkBRewrite,  mkBRewrite3,  getBRewrite3, noBwdRewrite
   , analyzeAndRewriteFwd,  analyzeAndRewriteBwd
   )
@@ -64,16 +67,34 @@ newtype FwdTransfer n f
                      , n O C -> f -> FactBase f
                      ) }
 
-newtype FwdRewrite m n f 
+newtype FwdRewrite m n f   -- see Note [Respects Fuel]
   = FwdRewrite3 { getFRewrite3 ::
                     ( n C O -> f -> m (Maybe (FwdRew m n f C O))
                     , n O O -> f -> m (Maybe (FwdRew m n f O O))
                     , n O C -> f -> m (Maybe (FwdRew m n f O C))
                     ) }
 data FwdRew m n f e x = FwdRew (Graph n e x) (FwdRewrite m n f)
-
   -- result of a rewrite is a new graph and a (possibly) new rewrite function
 
+wrapFR :: (forall e x . (n  e x -> f  -> m  (Maybe (FwdRew m  n  f  e x))) ->
+                        (n' e x -> f' -> m' (Maybe (FwdRew m' n' f' e x))))
+            -- ^ This argument may assume that any function passed to it
+            -- respects fuel, and it must return a result that respects fuel.
+       -> FwdRewrite m  n  f 
+       -> FwdRewrite m' n' f'      -- see Note [Respects Fuel]
+wrapFR wrap (FwdRewrite3 (f, m, l)) = FwdRewrite3 (wrap f, wrap m, wrap l)
+wrapFR2 :: (forall e x . (n1 e x -> f1 -> m1 (Maybe (FwdRew m1 n1 f1 e x))) ->
+                         (n2 e x -> f2 -> m2 (Maybe (FwdRew m2 n2 f2 e x))) ->
+                         (n3 e x -> f3 -> m3 (Maybe (FwdRew m3 n3 f3 e x))))
+            -- ^ This argument may assume that any function passed to it
+            -- respects fuel, and it must return a result that respects fuel.
+        -> FwdRewrite m1 n1 f1
+        -> FwdRewrite m2 n2 f2
+        -> FwdRewrite m3 n3 f3      -- see Note [Respects Fuel]
+wrapFR2 wrap2 (FwdRewrite3 (f1, m1, l1)) (FwdRewrite3 (f2, m2, l2)) =
+    FwdRewrite3 (wrap2 f1 f2, wrap2 m1 m2, wrap2 l1 l2)
+
+
 mkFTransfer3 :: (n C O -> f -> f)
              -> (n O O -> f -> f)
              -> (n O C -> f -> FactBase f)
@@ -83,6 +104,8 @@ mkFTransfer3 f m l = FwdTransfer3 (f, m, l)
 mkFTransfer :: (forall e x . n e x -> f -> Fact x f) -> FwdTransfer n f
 mkFTransfer f = FwdTransfer3 (f, f, f)
 
+-- | Functions passed to 'mkFRewrite3' should not be aware of the fuel supply.
+-- The result returned by 'mkFRewrite3' respects fuel.
 mkFRewrite3 :: FuelMonad m
             => (n C O -> f -> m (Maybe (Graph n C O)))
             -> (n O O -> f -> m (Maybe (Graph n O O)))
@@ -100,6 +123,8 @@ noRewrite _ _ = return Nothing
 
                                
 
+-- | Functions passed to 'mkFRewrite' should not be aware of the fuel supply.
+-- The result returned by 'mkFRewrite' respects fuel.
 mkFRewrite :: FuelMonad m => (forall e x . n e x -> f -> m (Maybe (Graph n e x)))
            -> FwdRewrite m n f
 mkFRewrite f = mkFRewrite3 f f f
@@ -186,7 +211,7 @@ arfGraph pass entries = graph
     block (BClosed h t)= block h  `cat` block t
 
     node n f
-      = do { fwdres <- withFuel =<< frewrite pass n f
+      = do { fwdres <- frewrite pass n f
            ; case fwdres of
                Nothing -> return (toDg f (toBlock n),
                                   ftransfer pass n f)
@@ -262,6 +287,28 @@ newtype BwdRewrite m n f
                     ) }
 data BwdRew m n f e x = BwdRew (Graph n e x) (BwdRewrite m n f)
 
+wrapBR :: (forall e x . Shape x 
+                      -> (n  e x -> Fact x f  -> m  (Maybe (BwdRew m  n  f  e x)))
+                      -> (n' e x -> Fact x f' -> m' (Maybe (BwdRew m' n' f' e x))))
+            -- ^ This argument may assume that any function passed to it
+            -- respects fuel, and it must return a result that respects fuel.
+       -> BwdRewrite m  n  f 
+       -> BwdRewrite m' n' f'      -- see Note [Respects Fuel]
+wrapBR wrap (BwdRewrite3 (f, m, l)) = BwdRewrite3 (wrap Open f, wrap Open m, wrap Closed l)
+
+wrapBR2 :: (forall e x . Shape x
+                       -> (n1 e x -> Fact x f1 -> m1 (Maybe (BwdRew m1 n1 f1 e x)))
+                       -> (n2 e x -> Fact x f2 -> m2 (Maybe (BwdRew m2 n2 f2 e x)))
+                       -> (n3 e x -> Fact x f3 -> m3 (Maybe (BwdRew m3 n3 f3 e x))))
+            -- ^ This argument may assume that any function passed to it
+            -- respects fuel, and it must return a result that respects fuel.
+        -> BwdRewrite m1 n1 f1
+        -> BwdRewrite m2 n2 f2
+        -> BwdRewrite m3 n3 f3      -- see Note [Respects Fuel]
+wrapBR2 wrap2 (BwdRewrite3 (f1, m1, l1)) (BwdRewrite3 (f2, m2, l2)) =
+    BwdRewrite3 (wrap2 Open f1 f2, wrap2 Open m1 m2, wrap2 Closed l1 l2)
+
+
 
 mkBTransfer3 :: (n C O -> f -> f) -> (n O O -> f -> f) ->
                 (n O C -> FactBase f -> f) -> BwdTransfer n f
@@ -270,6 +317,8 @@ mkBTransfer3 f m l = BwdTransfer3 (f, m, l)
 mkBTransfer :: (forall e x . n e x -> Fact x f -> f) -> BwdTransfer n f
 mkBTransfer f = BwdTransfer3 (f, f, f)
 
+-- | Functions passed to 'mkBRewrite3' should not be aware of the fuel supply.
+-- The result returned by 'mkBRewrite3' respects fuel.
 mkBRewrite3 :: FuelMonad m
             => (n C O -> f          -> m (Maybe (Graph n C O)))
             -> (n O O -> f          -> m (Maybe (Graph n O O)))
@@ -282,9 +331,12 @@ mkBRewrite3 f m l = BwdRewrite3 (lift f, lift m, lift l)
 noBwdRewrite :: Monad m => BwdRewrite m n f
 noBwdRewrite = BwdRewrite3 (noRewrite, noRewrite, noRewrite)
 
-mkBRewrite :: (forall e x . n e x -> Fact x f -> m (Maybe (BwdRew m n f e x)))
+-- | Functions passed to 'mkBRewrite' should not be aware of the fuel supply.
+-- The result returned by 'mkBRewrite' respects fuel.
+mkBRewrite :: FuelMonad m 
+           => (forall e x . n e x -> Fact x f -> m (Maybe (Graph n e x)))
            -> BwdRewrite m n f
-mkBRewrite f = BwdRewrite3 (f, f, f)
+mkBRewrite f = mkBRewrite3 f f f
 
 
 -----------------------------------------------------------------------------
@@ -335,7 +387,7 @@ arbGraph pass entries = graph
     block (BClosed h t)= block h  `cat` block t
 
     node n f
-      = do { bwdres <- withFuel =<< brewrite pass n f
+      = do { bwdres <- brewrite pass n f
            ; case bwdres of
                Nothing -> return (toDg entry_f (toBlock n), entry_f)
                             where entry_f = btransfer pass n f
@@ -703,3 +755,24 @@ instance ShapeLifter O C where
 getFact  :: DataflowLattice f -> Label -> FactBase f -> f
 getFact lat l fb = case lookupFact l fb of Just  f -> f
                                            Nothing -> fact_bot lat
+
+
+
+{-  Note [Respects fuel]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-}
+-- $fuel
+-- A value of type 'FwdRewrite' or 'BwdRewrite' /respects fuel/ if 
+-- any function contained within the value satisfies the following properties:
+--
+--   * When fuel is exhausted, it always returns 'Nothing'.
+--
+--   * When it returns @Just g rw@, it consumes /exactly/ one unit
+--     of fuel, and new rewrite 'rw' also respects fuel.
+--
+-- Provided that functions passed to 'mkFRewrite', 'mkFRewrite3', 
+-- 'mkBRewrite', and 'mkBRewrite3' are not aware of the fuel supply,
+-- the results respect fuel.
+--
+-- It is an /unchecked/ run-time error for the argument passed to 'wrapFR',
+-- 'wrapFR2', 'wrapBR', or 'warpBR2' to return a function that does not respect fuel.
index 6f00cab..9fcc707 100644 (file)
@@ -2,7 +2,7 @@
 
 module Compiler.Hoopl.Graph 
   ( O, C, Block(..), Body, Body'(..), Graph, Graph'(..)
-  , MaybeO(..), MaybeC(..), EitherCO
+  , MaybeO(..), MaybeC(..), Shape(..), IndexedCO
   , NonLocal(entryLabel, successors)
   , emptyBody, addBlock, bodyList
   )
@@ -71,10 +71,15 @@ data MaybeC ex t where
   JustC    :: t -> MaybeC C t
   NothingC ::      MaybeC O t
 
+-- | Dynamic shape value
+data Shape ex where
+  Closed :: Shape C
+  Open   :: Shape O
+
 -- | Either type indexed by closed/open using type families
-type family   EitherCO e a b :: *
-type instance EitherCO C a b = a
-type instance EitherCO O a b = b
+type family IndexedCO ex a b :: *
+type instance IndexedCO C a b = a
+type instance IndexedCO O a b = b
 
 instance Functor (MaybeO ex) where
   fmap _ NothingO = NothingO
diff --git a/src/Compiler/Hoopl/Wrappers.hs b/src/Compiler/Hoopl/Wrappers.hs
new file mode 100644 (file)
index 0000000..2b4355a
--- /dev/null
@@ -0,0 +1,7 @@
+module Compiler.Hoopl.Wrappers {-# DEPRECATED "Use only if you known what you are doing and can preserve the 'respects fuel' invariant" #-}
+  ( wrapFR, wrapFR2, wrapBR, wrapBR2
+  )
+where
+
+import Compiler.Hoopl.Dataflow
+
index 7d4ad82..10f9463 100644 (file)
@@ -148,16 +148,16 @@ joinOutFacts lat n f = foldr join (fact_bot lat) facts
   where join (lbl, new) old = snd $ fact_join lat lbl (OldFact old) (NewFact new)
         facts = [(s, fromJust fact) | s <- successors n, let fact = lookupFact s f, isJust fact]
 
--- | A fold function that relies on the EitherCO type function.
+-- | A fold function that relies on the IndexedCO type function.
 --   Note that the type parameter e is available to the functions
 --   that are applied to the middle and last nodes.
 tfFoldBlock :: forall n bc bo c e x .
                ( n C O -> bc
-               , n O O -> EitherCO e bc bo -> EitherCO e bc bo
-               , n O C -> EitherCO e bc bo -> c)
-            -> (Block n e x -> bo -> EitherCO x c (EitherCO e bc bo))
+               , n O O -> IndexedCO e bc bo -> IndexedCO e bc bo
+               , n O C -> IndexedCO e bc bo -> c)
+            -> (Block n e x -> bo -> IndexedCO x c (IndexedCO e bc bo))
 tfFoldBlock (f, m, l) bl bo = block bl
-  where block :: forall x . Block n e x -> EitherCO x c (EitherCO e bc bo)
+  where block :: forall x . Block n e x -> IndexedCO x c (IndexedCO e bc bo)
         block (BFirst  n)       = f n
         block (BMiddle n)       = m n bo
         block (BLast   n)       = l n bo
@@ -165,7 +165,7 @@ tfFoldBlock (f, m, l) bl bo = block bl
         block (b1 `BClosed` b2) = oblock b2 $ block b1
         block (b1 `BHead` n)    = m n $ block b1
         block (n `BTail` b2)    = oblock b2 $ m n bo
-        oblock :: forall x . Block n O x -> EitherCO e bc bo -> EitherCO x c (EitherCO e bc bo)
+        oblock :: forall x . Block n O x -> IndexedCO e bc bo -> IndexedCO x c (IndexedCO e bc bo)
         oblock (BMiddle n)       = m n
         oblock (BLast   n)       = l n
         oblock (b1 `BCat`    b2) = oblock b1 `cat` oblock b2
@@ -175,8 +175,8 @@ tfFoldBlock (f, m, l) bl bo = block bl
 
 type NodeList' e x n = (MaybeC e (n C O), [n O O], MaybeC x (n O C))
 blockToNodeList''' ::
-  forall n e x. ( EitherCO e (NodeList' C O n) (NodeList' O O n) ~ NodeList' e O n
-                , EitherCO x (NodeList' e C n) (NodeList' e O n) ~ NodeList' e x n) =>
+  forall n e x. ( IndexedCO e (NodeList' C O n) (NodeList' O O n) ~ NodeList' e O n
+                , IndexedCO x (NodeList' e C n) (NodeList' e O n) ~ NodeList' e x n) =>
     Block n e x -> NodeList' e x n
 blockToNodeList''' b = (h, reverse ms', t)
   where
@@ -259,14 +259,14 @@ fbnf3 :: forall n a b c .
          ( n C O       -> a -> b
          , n O O       -> b -> b
          , n O C       -> b -> c)
-      -> (forall e x . Block n e x -> EitherCO e a b -> EitherCO x c b)
+      -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
 fbnf3 (ff, fm, fl) block = unFF3 $ scottFoldBlock (ScottBlock f m l cat) block
     where f n = FF3 $ ff n
           m n = FF3 $ fm n
           l n = FF3 $ fl n
           FF3 f `cat` FF3 f' = FF3 $ f' . f
 
-newtype FF3 a b c e x = FF3 { unFF3 :: EitherCO e a b -> EitherCO x c b }
+newtype FF3 a b c e x = FF3 { unFF3 :: IndexedCO e a b -> IndexedCO x c b }
 
 blockToNodeList'' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
 blockToNodeList'' = finish . unList . scottFoldBlock (ScottBlock f m l cat)
@@ -349,18 +349,18 @@ foldBlockNodesF3 :: forall n a b c .
                    ( n C O       -> a -> b
                    , n O O       -> b -> b
                    , n O C       -> b -> c)
-                 -> (forall e x . Block n e x -> EitherCO e a b -> EitherCO x c b)
+                 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
 foldBlockNodesF  :: forall n a .
                     (forall e x . n e x       -> a -> a)
-                 -> (forall e x . Block n e x -> EitherCO e a a -> EitherCO x a a)
+                 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)
 foldBlockNodesB3 :: forall n a b c .
                    ( n C O       -> b -> c
                    , n O O       -> b -> b
                    , n O C       -> a -> b)
-                 -> (forall e x . Block n e x -> EitherCO x a b -> EitherCO e c b)
+                 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)
 foldBlockNodesB  :: forall n a .
                     (forall e x . n e x       -> a -> a)
-                 -> (forall e x . Block n e x -> EitherCO x a a -> EitherCO e a a)
+                 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)
 -- | Fold a function over every node in a graph.
 -- The fold function must be polymorphic in the shape of the nodes.
 
@@ -370,7 +370,7 @@ foldGraphNodes :: forall n a .
 
 
 foldBlockNodesF3 (ff, fm, fl) = block
-  where block :: forall e x . Block n e x -> EitherCO e a b -> EitherCO x c b
+  where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b
         block (BFirst  node)    = ff node
         block (BMiddle node)    = fm node
         block (BLast   node)    = fl node
@@ -382,7 +382,7 @@ foldBlockNodesF3 (ff, fm, fl) = block
 foldBlockNodesF f = foldBlockNodesF3 (f, f, f)
 
 foldBlockNodesB3 (ff, fm, fl) = block
-  where block :: forall e x . Block n e x -> EitherCO x a b -> EitherCO e c b
+  where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b
         block (BFirst  node)    = ff node
         block (BMiddle node)    = fm node
         block (BLast   node)    = fl node
@@ -417,7 +417,7 @@ foldGraphNodes f = graph
 -- is or is not present depending on the shape of the block.
 --
 -- The blockToNodeList function cannot be currently expressed using
--- foldBlockNodesB, because it returns EitherCO e a b, which means
+-- foldBlockNodesB, because it returns IndexedCO e a b, which means
 -- two different types depending on the shape of the block entry.
 -- But blockToNodeList returns one of four possible types, depending
 -- on the shape of the block entry *and* exit.
index abd1339..08ff239 100644 (file)
@@ -1,5 +1,5 @@
 Name:                hoopl
-Version:             3.8.3.0
+Version:             3.8.4.0
 Description:         Higher-order optimization library
 License:             BSD3
 License-file:        LICENSE
@@ -16,6 +16,7 @@ Extra-source-files:  README, hoopl.pdf, CHANGES, FAQ
 Library
   Build-Depends:     base >= 3 && < 5, containers
   Exposed-modules:   Compiler.Hoopl,
+                     Compiler.Hoopl.Wrappers,
                      Compiler.Hoopl.Passes.Dominator,
                      Compiler.Hoopl.Passes.DList,
 --                       Compiler.Hoopl.DataflowFold,
index bdf3a86..65b5253 100644 (file)
@@ -63,8 +63,8 @@ varHasLit = mkFTransfer ft
 -- @ start cprop.tex
 --------------------------------------------------
 -- Rewriting: propagate and fold constants
-constProp :: Monad m => FwdRewrite m Node ConstFact
-constProp = shallowFwdRw cp
+constProp :: FuelMonad m => FwdRewrite m Node ConstFact
+constProp = mkFRewrite cp
  where
    cp node f
      = return $ liftM nodeToG $ mapVN (lookup f) node
index 4591860..5762a47 100644 (file)
@@ -37,10 +37,10 @@ liveness = mkBTransfer live
     addVar s (Var v) = S.insert v s
     addVar s _       = s
      
-deadAsstElim :: forall m . Monad m => BwdRewrite m Insn Live
-deadAsstElim = shallowBwdRw d
+deadAsstElim :: forall m . FuelMonad m => BwdRewrite m Insn Live
+deadAsstElim = mkBRewrite d
   where
-    d :: SimpleBwdRewrite m Insn Live
-    d (Assign x _) live = if x `S.member` live then return Nothing
-                                               else return $ Just emptyGraph
+    d :: Insn e x -> Fact x Live -> m (Maybe (Graph Insn e x))
+    d (Assign x _) live
+        | not (x `S.member` live) = return $ Just emptyGraph
     d _ _ = return Nothing
index e42543c..0c53e83 100644 (file)
@@ -14,7 +14,7 @@ type Node = Insn
 
 --------------------------------------------------
 -- Simplification ("constant folding")
-simplify :: Monad m => FwdRewrite m Node f
+simplify :: FuelMonad m => FwdRewrite m Node f
 simplify = deepFwdRw simp
  where
   simp node _ = return $ liftM nodeToG $ s_node node
index dfad1bd..2056bb4 100644 (file)
@@ -60,7 +60,7 @@ optTest' file text =
     bwd  = BwdPass { bp_lattice = liveLattice, bp_transfer = liveness
                    , bp_rewrite = deadAsstElim }
 
-constPropPass :: Monad m => FwdPass m Insn ConstFact
+constPropPass :: FuelMonad m => FwdPass m Insn ConstFact
 -- @ start cprop.tex
 
 ----------------------------------------