added CheckpointMonad, which is now used in 'fixpoint' and friends
authorNorman Ramsey <nr@cs.tufts.edu>
Thu, 17 Jun 2010 17:42:05 +0000 (13:42 -0400)
committerNorman Ramsey <nr@cs.tufts.edu>
Thu, 17 Jun 2010 17:42:05 +0000 (13:42 -0400)
src/Compiler/Hoopl.hs
src/Compiler/Hoopl/Checkpoint.hs [new file with mode: 0644]
src/Compiler/Hoopl/Dataflow.hs
src/Compiler/Hoopl/Fuel.hs
src/Compiler/Hoopl/Unique.hs
src/Compiler/Hoopl/XUtil.hs
src/hoopl.cabal

index 18b49d8..806dcf0 100644 (file)
@@ -3,6 +3,7 @@ module Compiler.Hoopl
   , module Compiler.Hoopl.MkGraph
   , module Compiler.Hoopl.XUtil
   , module Compiler.Hoopl.Collections
+  , module Compiler.Hoopl.Checkpoint
   , module Compiler.Hoopl.Dataflow
   , module Compiler.Hoopl.Label
   , module Compiler.Hoopl.Pointed
@@ -15,6 +16,7 @@ module Compiler.Hoopl
   )
 where
 
+import Compiler.Hoopl.Checkpoint
 import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Combinators
 import Compiler.Hoopl.Dataflow hiding ( FwdRew(..), BwdRew(..)
diff --git a/src/Compiler/Hoopl/Checkpoint.hs b/src/Compiler/Hoopl/Checkpoint.hs
new file mode 100644 (file)
index 0000000..384566d
--- /dev/null
@@ -0,0 +1,17 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module Compiler.Hoopl.Checkpoint
+  ( CheckpointMonad(..)
+  )
+where
+
+-- | Obeys the following law:
+-- for all @m@ 
+-- @
+--    do { s <- checkpoint; m; restart s } == return ()
+-- @
+class Monad m => CheckpointMonad m where
+  type Checkpoint m
+  checkpoint :: m (Checkpoint m)
+  restart    :: Checkpoint m -> m () 
+
index e371e0b..47d1e49 100644 (file)
@@ -19,6 +19,7 @@ where
 import Control.Monad
 import Data.Maybe
 
+import Compiler.Hoopl.Checkpoint
 import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Fuel
 import Compiler.Hoopl.Graph hiding (Graph) -- hiding so we can redefine
@@ -137,7 +138,7 @@ type instance Fact O f = f
 -- | if the graph being analyzed is open at the entry, there must
 --   be no other entry point, or all goes horribly wrong...
 analyzeAndRewriteFwd
-   :: forall m n f e x entries. (FuelMonad m, NonLocal n, LabelsPtr entries)
+   :: forall m n f e x entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries)
    => FwdPass m n f
    -> MaybeC e entries
    -> Graph n e x -> Fact e f
@@ -162,7 +163,7 @@ distinguishedExitFact g f = maybe g
 type Entries e = MaybeC e [Label]
 
 arfGraph :: forall m n f e x .
-            (NonLocal n, FuelMonad m) => FwdPass m n f -> 
+            (NonLocal n, CheckpointMonad m) => FwdPass m n f -> 
             Entries e -> Graph n e x -> Fact e f -> m (DG f n e x, Fact x f)
 arfGraph pass entries = graph
   where
@@ -241,7 +242,7 @@ arfGraph pass entries = graph
                     -- the Body are in the 'DG f n C C'
 -- @ start bodyfun.tex
     body entries blockmap init_fbase
-      = fixpoint Fwd lattice do_block blocks init_fbase
+      = fixpoint' Fwd lattice do_block blocks init_fbase
       where
         blocks  = forwardBlockList entries blockmap
         lattice = fp_lattice pass
@@ -344,7 +345,7 @@ mkBRewrite f = mkBRewrite3 f f f
 -----------------------------------------------------------------------------
 
 arbGraph :: forall m n f e x .
-            (NonLocal n, FuelMonad m) => BwdPass m n f -> 
+            (NonLocal n, CheckpointMonad m) => BwdPass m n f -> 
             Entries e -> Graph n e x -> Fact x f -> m (DG f n e x, Fact e f)
 arbGraph pass entries = graph
   where
@@ -418,7 +419,7 @@ arbGraph pass entries = graph
                    -- in the Body; the facts for Labels *in*
                     -- the Body are in the 'DG f n C C'
     body entries blockmap init_fbase
-      = fixpoint Bwd (bp_lattice pass) do_block blocks init_fbase
+      = fixpoint' Bwd (bp_lattice pass) do_block blocks init_fbase
       where
         blocks = backwardBlockList entries blockmap
         do_block b f = do (g, f) <- block b f
@@ -448,7 +449,7 @@ effects.)
 -- | if the graph being analyzed is open at the exit, I don't
 --   quite understand the implications of possible other exits
 analyzeAndRewriteBwd
-   :: (FuelMonad m, NonLocal n, LabelsPtr entries)
+   :: (CheckpointMonad m, NonLocal n, LabelsPtr entries)
    => BwdPass m n f
    -> MaybeC e entries -> Graph n e x -> Fact x f
    -> m (Graph n e x, FactBase f, MaybeO e f)
@@ -507,14 +508,14 @@ fixpoint :: forall m block n f.
 -}
 -- @ start fptype.tex
 data Direction = Fwd | Bwd
-fixpoint :: forall m n f. (FuelMonad m, NonLocal n)
+_fixpoint :: forall m n f. (FuelMonad m, NonLocal n)
  => Direction
  -> DataflowLattice f
  -> (Block n C C -> Fact C f -> m (DG f n C C, Fact C f))
  -> [Block n C C]
  -> (Fact C f -> m (DG f n C C, Fact C f))
 -- @ end fptype.tex
-fixpoint direction lat do_block blocks init_fbase
+_fixpoint direction lat do_block blocks init_fbase
   = do { fuel <- getFuel  
        ; tx_fb <- loop fuel init_fbase
        ; return (tfb_rg tx_fb, 
@@ -574,11 +575,15 @@ fixpoint direction lat do_block blocks init_fbase
                        ; loop fuel (tfb_fbase tx_fb) } }
 
 
+
+
+{-
+-- this doesn't work because it can't be implemented
 class Monad m => FixpointMonad m where
   observeChangedFactBase :: m (Maybe (FactBase f)) -> Maybe (FactBase f)
+-}
 
-
-fixpoint' :: forall m n f. (FixpointMonad m, NonLocal n)
+fixpoint' :: forall m n f. (CheckpointMonad m, NonLocal n)
  => Direction
  -> DataflowLattice f
  -> (Block n C C -> Fact C f -> m (DG f n C C, Fact C f))
@@ -631,6 +636,21 @@ fixpoint' direction lat do_block blocks init_fbase
         
 
     loop :: FactBase f -> m (TxFactBase n f)
+    loop fbase 
+      = do { s <- checkpoint
+           ; let init_tx = TxFB { tfb_fbase = fbase
+                                , tfb_cha   = NoChange
+                                , tfb_rg    = dgnilC
+                                , tfb_lbls  = setEmpty }
+           ; tx_fb <- tx_blocks tagged_blocks init_tx
+           ; case tfb_cha tx_fb of
+               NoChange   -> return tx_fb
+               SomeChange 
+                 -> do { restart s
+                       ; loop (tfb_fbase tx_fb) } }
+           
+
+{-
     loop fbase = case changedFactBase iteration of
                         Nothing -> iteration
                         Just fb -> loop fb
@@ -648,6 +668,7 @@ fixpoint' direction lat do_block blocks init_fbase
               ; case tfb_cha tx_fb of
                   NoChange -> return Nothing
                   SomeChange -> return $ Just (tfb_fbase tx_fb) }
+-}
 
 
 {-  Note [TxFactBase invariants]
index f31bb8a..260fd43 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+
 -----------------------------------------------------------------------------
 --             The fuel monad
 -----------------------------------------------------------------------------
@@ -13,6 +15,7 @@ module Compiler.Hoopl.Fuel
   )
 where
 
+import Compiler.Hoopl.Checkpoint
 import Compiler.Hoopl.Unique
 
 class Monad m => FuelMonad m where
@@ -46,6 +49,12 @@ instance Monad m => Monad (CheckingFuelMonad m) where
   return a = FM (\f -> return (a, f))
   fm >>= k = FM (\f -> do { (a, f') <- unFM fm f; unFM (k a) f' })
 
+instance CheckpointMonad m => CheckpointMonad (CheckingFuelMonad m) where
+  type Checkpoint (CheckingFuelMonad m) = (Fuel, Checkpoint m)
+  checkpoint = FM $ \fuel -> do { s <- checkpoint
+                                ; return ((fuel, s), fuel) }
+  restart (fuel, s) = FM $ \_ -> do { restart s; return ((), fuel) }
+
 instance UniqueMonad m => UniqueMonad (CheckingFuelMonad m) where
   freshUnique = FM (\f -> do { l <- freshUnique; return (l, f) })
 
@@ -70,6 +79,13 @@ instance Monad m => FuelMonad (InfiniteFuelMonad m) where
   getFuel   = return infiniteFuel
   setFuel _ = return ()
 
+instance CheckpointMonad m => CheckpointMonad (InfiniteFuelMonad m) where
+  type Checkpoint (InfiniteFuelMonad m) = Checkpoint m
+  checkpoint = IFM checkpoint
+  restart s  = IFM $ restart s
+
+
+
 instance FuelMonadT InfiniteFuelMonad where
   runWithFuel _ = unIFM
 
index f87834d..f5b7bbb 100644 (file)
@@ -11,6 +11,7 @@ module Compiler.Hoopl.Unique
 
 where
 
+import Compiler.Hoopl.Checkpoint
 import Compiler.Hoopl.Collections
 
 import qualified Data.IntMap as M
@@ -107,6 +108,11 @@ instance Monad SimpleUniqueMonad where
 instance UniqueMonad SimpleUniqueMonad where
   freshUnique = SUM $ \(u:us) -> (u, us)
 
+instance CheckpointMonad SimpleUniqueMonad where
+  type Checkpoint SimpleUniqueMonad = [Unique]
+  checkpoint = SUM $ \us -> (us, us)
+  restart us = SUM $ \_  -> ((), us)
+
 runSimpleUniqueMonad :: SimpleUniqueMonad a -> a
 runSimpleUniqueMonad m = fst (unSUM m allUniques)
 
index 10f9463..98a2f7f 100644 (file)
@@ -26,9 +26,9 @@ where
 
 import Data.Maybe
 
+import Compiler.Hoopl.Checkpoint
 import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Dataflow
-import Compiler.Hoopl.Fuel
 import Compiler.Hoopl.Graph
 import Compiler.Hoopl.Label
 import Compiler.Hoopl.Util
@@ -38,7 +38,7 @@ import Compiler.Hoopl.Util
 -- A set of entry points must be supplied; blocks not reachable from
 -- the set are thrown away.
 analyzeAndRewriteFwdBody
-   :: forall m n f entries. (FuelMonad m, NonLocal n, LabelsPtr entries)
+   :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries)
    => FwdPass m n f
    -> entries -> Body n -> FactBase f
    -> m (Body n, FactBase f)
@@ -47,7 +47,7 @@ analyzeAndRewriteFwdBody
 -- A set of entry points must be supplied; blocks not reachable from
 -- the set are thrown away.
 analyzeAndRewriteBwdBody
-   :: forall m n f entries. (FuelMonad m, NonLocal n, LabelsPtr entries)
+   :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries)
    => BwdPass m n f 
    -> entries -> Body n -> FactBase f 
    -> m (Body n, FactBase f)
@@ -82,7 +82,7 @@ mapBodyFacts anal b f = anal (GMany NothingO b NothingO) f >>= bodyFacts
 -- from having to specify a type signature for 'NothingO', which beginners
 -- might find confusing and experts might find annoying.
 analyzeAndRewriteFwdOx
-   :: forall m n f x. (FuelMonad m, NonLocal n)
+   :: forall m n f x. (CheckpointMonad m, NonLocal n)
    => FwdPass m n f -> Graph n O x -> f -> m (Graph n O x, FactBase f, MaybeO x f)
 
 -- | Backward dataflow analysis and rewriting for the special case of a 
@@ -90,7 +90,7 @@ analyzeAndRewriteFwdOx
 -- from having to specify a type signature for 'NothingO', which beginners
 -- might find confusing and experts might find annoying.
 analyzeAndRewriteBwdOx
-   :: forall m n f x. (FuelMonad m, NonLocal n)
+   :: forall m n f x. (CheckpointMonad m, NonLocal n)
    => BwdPass m n f -> Graph n O x -> Fact x f -> m (Graph n O x, FactBase f, f)
 
 -- | A value that can be used for the entry point of a graph open at the entry.
index 08ff239..c4cf3db 100644 (file)
@@ -1,5 +1,5 @@
 Name:                hoopl
-Version:             3.8.4.0
+Version:             3.8.5.0
 Description:         Higher-order optimization library
 License:             BSD3
 License-file:        LICENSE
@@ -25,6 +25,7 @@ Library
   Other-modules:     Compiler.Hoopl.GraphUtil,
                      -- GraphUtil should *never* be seen by clients.
                      -- The remaining modules are hidden *provisionally*
+                       Compiler.Hoopl.Checkpoint,
                        Compiler.Hoopl.Collections,
                        Compiler.Hoopl.Combinators,
                        Compiler.Hoopl.Dataflow,