Merge branch 'three-eight' of linux.cs.tufts.edu:/r/c--/papers/dfopt into three-eight
authorNorman Ramsey <nr@cs.tufts.edu>
Fri, 30 Apr 2010 19:29:44 +0000 (15:29 -0400)
committerNorman Ramsey <nr@cs.tufts.edu>
Fri, 30 Apr 2010 19:29:44 +0000 (15:29 -0400)
Conflicts:

src/Compiler/Hoopl/Dataflow.hs
src/Compiler/Hoopl/Fuel.hs
src/Compiler/Hoopl/MkGraph.hs
src/hoopl.cabal

expunged 'allUniques'; need to provide a simple instance of HooplMonad.

1  2 
src/Compiler/Hoopl.hs
src/Compiler/Hoopl/Dataflow.hs
src/Compiler/Hoopl/Fuel.hs
src/Compiler/Hoopl/Label.hs
src/Compiler/Hoopl/MkGraph.hs
src/Compiler/Hoopl/Unique.hs
src/Compiler/Hoopl/XUtil.hs
src/hoopl.cabal

@@@ -16,14 -17,15 +17,15 @@@ wher
  import Compiler.Hoopl.Combinators
  import Compiler.Hoopl.Dataflow
  import Compiler.Hoopl.Debug
--import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel)
++import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel, FuelMonadT)
  import Compiler.Hoopl.Graph hiding 
-    ( BodyEmpty, BodyUnit, BodyCat
+    ( Body
     , BCat, BHead, BTail, BClosed -- OK to expose BFirst, BMiddle, BLast
     )
- import Compiler.Hoopl.Label hiding (allLabels)
+ import Compiler.Hoopl.Label hiding (lblOfUniq, uniqOfLbl)
  import Compiler.Hoopl.MkGraph
  import Compiler.Hoopl.Pointed
  import Compiler.Hoopl.Show
  import Compiler.Hoopl.Util
 -import Compiler.Hoopl.Unique hiding (allUniques, intOfUniq)
++import Compiler.Hoopl.Unique hiding (intOfUniq, uniqOfInt)
  import Compiler.Hoopl.XUtil
@@@ -474,13 -475,14 +474,13 @@@ updateFact lat lbls (lbl, new_fact) (ch
           where join old_fact = fact_extend lat lbl (OldFact old_fact) (NewFact new_fact)
      new_fbase = extendFactBase fbase lbl res_fact
  
- fixpoint :: forall m block n f. (FuelMonad m, Edges (block n))
 -fixpoint :: forall block n f. (Edges n, Edges (block n))
++fixpoint :: forall m block n f. (FuelMonad m, Edges n, Edges (block n))
           => Bool      -- Going forwards?
           -> DataflowLattice f
 -         -> (block n C C -> FactBase f
 -              -> FuelMonad (RG f n C C, [(Label, f)]))
 +         -> (block n C C -> FactBase f -> m (RG f n C C, [(Label, f)]))
           -> FactBase f 
           -> [block n C C]
 -         -> FuelMonad (RG f n C C, FactBase f)
 +         -> m (RG f n C C, FactBase f)
  fixpoint is_fwd lat do_block init_fbase untagged_blocks
    = do { fuel <- getFuel  
         ; tx_fb <- loop fuel init_fbase
@@@ -3,77 -3,41 +3,82 @@@
  -----------------------------------------------------------------------------
  
  module Compiler.Hoopl.Fuel
-   ( Fuel, infiniteFuel
 -  ( Fuel
 -  , FuelMonad, withFuel, getFuel, setFuel
 -  , freshUnique
 -    
 -  , runWithFuel, runWithFuelAndUniques
++  ( Fuel, infiniteFuel, fuelRemaining
 +  , withFuel
-   , HooplMonad(..), freshLabel -- these belong somewhere else
 +  , FuelMonad(..)
 +  , FuelMonadT(..)
 +  , CheckingFuelMonad
 +  , InfiniteFuelMonad
    )
  where
  
- import Compiler.Hoopl.Label
- class Monad m => HooplMonad m where
-   getLabel :: m Label
- {-# DEPRECATED getLabel "will be replaced with something based on getUnique" #-}
- freshLabel :: HooplMonad m => m Label
- freshLabel = getLabel
+ import Compiler.Hoopl.Unique
  
 -type Fuel    = Int
 +class Monad m => FuelMonad m where
 +  getFuel :: m Fuel
 +  setFuel :: Fuel -> m ()
  
 -newtype FuelMonad a = FM { unFM :: Fuel -> [Unique] -> (a, Fuel, [Unique]) }
++-- | Find out how much fuel remains after a computation.
++-- Can be subtracted from initial fuel to get total consumption.
++fuelRemaining :: FuelMonad m => m Fuel
++fuelRemaining = getFuel
 -instance Monad FuelMonad where
 -  return x = FM (\f u -> (x,f,u))
 -  m >>= k  = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')
 +class FuelMonadT fm where
 +  runWithFuel :: (Monad m, FuelMonad (fm m)) => Fuel -> fm m a -> m a
  
 -withFuel :: Maybe a -> FuelMonad (Maybe a)
 +
 +type Fuel = Int
 +
 +withFuel :: FuelMonad m => Maybe a -> m (Maybe a)
  withFuel Nothing  = return Nothing
 -withFuel (Just r) = FM (\f u -> if f==0 then (Nothing, f, u)
 -                                else (Just r, f-1, u))
 +withFuel (Just r) = do f <- getFuel
 +                       if f == 0 then return Nothing
 +                        else setFuel (f-1) >> return (Just r)
 +
 +
 +----------------------------------------------------------------
 +
 +newtype CheckingFuelMonad m a = FM { unFM :: Fuel -> m (a, Fuel) }
 +
 +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' })
  
 -getFuel :: FuelMonad Fuel
 -getFuel = FM (\f u -> (f,f,u))
 +instance HooplMonad m => HooplMonad (CheckingFuelMonad m) where
-   getLabel = FM (\f -> do { l <- getLabel; return (l, f) })
++  freshUnique = FM (\f -> do { l <- freshUnique; return (l, f) })
  
 -setFuel :: Fuel -> FuelMonad ()
 -setFuel f = FM (\_ u -> ((), f, u))
 +instance Monad m => FuelMonad (CheckingFuelMonad m) where
 +  getFuel   = FM (\f -> return (f,f))
 +  setFuel f = FM (\_ -> return ((),f))
  
 -runWithFuel :: Fuel -> FuelMonad a -> a
 -runWithFuel fuel m = runWithFuelAndUniques fuel allUniques m
 +instance FuelMonadT CheckingFuelMonad where
 +  runWithFuel fuel m = do { (a, _) <- unFM m fuel; return a }
  
-   getLabel = IFM $ getLabel
 +----------------------------------------------------------------
 +
 +newtype InfiniteFuelMonad m a = IFM { unIFM :: m a }
 +instance Monad m => Monad (InfiniteFuelMonad m) where
 +  return a = IFM $ return a
 +  m >>= k  = IFM $ do { a <- unIFM m; unIFM (k a) }
 +
 +instance HooplMonad m => HooplMonad (InfiniteFuelMonad m) where
- infiniteFuel = maxBound
++  freshUnique = IFM $ freshUnique
 +
 +instance Monad m => FuelMonad (InfiniteFuelMonad m) where
 +  getFuel   = return infiniteFuel
 +  setFuel _ = return ()
 +
 +instance FuelMonadT InfiniteFuelMonad where
 +  runWithFuel _ = unIFM
 +
 +infiniteFuel :: Fuel -- effectively infinite, any, but subtractable
++infiniteFuel = maxBound
++{-
+ runWithFuelAndUniques :: Fuel -> [Unique] -> FuelMonad a -> a
+ runWithFuelAndUniques fuel uniques m = a
+   where (a, _, _) = unFM m fuel uniques
+ freshUnique :: FuelMonad Unique
+ freshUnique = FM (\f (l:ls) -> (l, f, ls))
++-}
++
@@@ -1,8 -1,7 +1,9 @@@
  module Compiler.Hoopl.Label
 -  ( Label, lblOfUniq, uniqOfLbl
 +  ( Label
-   , allLabels -- to be used only by the Fuel monad
++  , getLabel
++  , lblOfUniq, uniqOfLbl -- GHC use only
    , LabelMap, emptyLabelMap, mkLabelMap, lookupLabel, extendLabelMap
-             , delFromLabelMap, unionLabelMap
+             , delFromLabelMap, unionLabelMap, mapLabelMap, foldLabelMap
              , elemLabelMap, labelMapLabels, labelMapList
    , FactBase, noFacts, mkFactBase, unitFact, lookupFact, extendFactBase
              , delFromFactBase, unionFactBase, mapFactBase, mapWithLFactBase
@@@ -17,16 -18,17 +20,20 @@@ import Compiler.Hoopl.Uniqu
  import qualified Data.IntMap as M
  import qualified Data.IntSet as S
  
--newtype Label = Label { unLabel :: Int }
++newtype Label = Label { unLabel :: Int } -- XXX this should be Unique
    deriving (Eq, Ord)
  
--instance Show Label where
--  show (Label n) = "L" ++ show n
 -
+ lblOfUniq :: Unique -> Label
 -lblOfUniq u = Label $ intOfUniq u
++lblOfUniq = Label . intOfUniq
  
 -uniqOfLbl (Label u) = uniqOfInt u
+ uniqOfLbl :: Label -> Unique
- allLabels :: [Label]
- allLabels = map Label [1..]
++uniqOfLbl = uniqOfInt . unLabel
 +
++instance Show Label where
++  show (Label n) = "L" ++ show n
 +
++getLabel :: HooplMonad m => m Label
++getLabel = do { u <- freshUnique; return $ Label $ intOfUniq u }
  
  -----------------------------------------------------------------------------
  --            Label, FactBase, LabelSet
@@@ -10,10 -10,12 +10,11 @@@ module Compiler.Hoopl.MkGrap
      )
  where
  
- import Compiler.Hoopl.Label (Label)
+ import Compiler.Hoopl.Label (Label, lblOfUniq)
  import Compiler.Hoopl.Graph
--import Compiler.Hoopl.Fuel
  import qualified Compiler.Hoopl.GraphUtil as U
+ import Compiler.Hoopl.Label (unionLabelMap)
+ import Compiler.Hoopl.Unique
  import Control.Monad (liftM2)
  
  {-|
@@@ -103,10 -105,10 +104,10 @@@ instance GraphRep Graph wher
    (<*>)       = U.gSplice
    (|*><*|)    = U.gSplice
    mkMiddle    = GUnit . BMiddle
-   mkExit   block = GMany NothingO      BodyEmpty (JustO block)
-   mkEntry  block = GMany (JustO block) BodyEmpty NothingO
+   mkExit   block = GMany NothingO      emptyBody (JustO block)
+   mkEntry  block = GMany (JustO block) emptyBody NothingO
  
 -instance GraphRep AGraph where
 +instance Monad m => GraphRep (AGraph m) where
    emptyGraph  = aGraphOfGraph emptyGraph
    emptyClosedGraph = aGraphOfGraph emptyClosedGraph
    (<*>)       = liftA2 (<*>)
@@@ -136,32 -138,32 +137,35 @@@ aGraphOfGraph = A . retur
  -- fresh labels can be acquired in a single call.
  -- 
  -- For example usage see implementations of 'mkIfThenElse' and 'mkWhileDo'.
- class Labels l where
-   withFreshLabels :: HooplMonad m => (l -> AGraph m n e x) -> AGraph m n e x
+ class Uniques u where
 -  withFresh :: (u -> AGraph n e x) -> AGraph n e x
++  withFresh :: HooplMonad m => (u -> AGraph m n e x) -> AGraph m n e x
  
- instance Labels Label where
-   withFreshLabels f = A $ freshLabel >>= (graphOfAGraph . f)
+ instance Uniques Unique where
+   withFresh f = A $ freshUnique >>= (graphOfAGraph . f)
+ instance Uniques Label where
+   withFresh f = A $ freshUnique >>= (graphOfAGraph . f . lblOfUniq)
  
  -- | Lifts binary 'Graph' functions into 'AGraph' functions.
 -liftA2 :: (Graph  n a b -> Graph  n c d -> Graph  n e f)
 -       -> (AGraph n a b -> AGraph n c d -> AGraph n e f)
 +liftA2 :: Monad m
 +       => (Graph    n a b -> Graph    n c d -> Graph    n e f)
 +       -> (AGraph m n a b -> AGraph m n c d -> AGraph m n e f)
  liftA2 f (A g) (A g') = A (liftM2 f g g')
  
  -- | Extend an existing 'AGraph' with extra basic blocks "out of line".
  -- No control flow is implied.  Simon PJ should give example use case.
 -addBlocks      :: HooplNode n
 -               => AGraph n e x -> AGraph n C C -> AGraph n e x
 +addBlocks      :: (HooplNode n, HooplMonad m)
 +               => AGraph m n e x -> AGraph m n C C -> AGraph m n e x
  addBlocks (A g) (A blocks) = A $ g >>= \g -> blocks >>= add g
 -  where add :: HooplNode n => Graph n e x -> Graph n C C -> FuelMonad (Graph n e x)
 +  where add :: (HooplMonad m, HooplNode n)
 +            => Graph n e x -> Graph n C C -> m (Graph n e x)
-         add (GMany e body x) (GMany NothingO body' NothingO) =
-           return $ GMany e (body `BodyCat` body') x
+         add (GMany e (Body body) x) (GMany NothingO (Body body') NothingO) =
+           return $ GMany e (Body $ unionLabelMap body body') x
          add g@GNil      blocks = spliceOO g blocks
          add g@(GUnit _) blocks = spliceOO g blocks
 -        spliceOO :: HooplNode n => Graph n O O -> Graph n C C -> FuelMonad(Graph n O O)
 +        spliceOO :: (HooplNode n, HooplMonad m)
 +                 => Graph n O O -> Graph n C C -> m (Graph n O O)
-         spliceOO g blocks = graphOfAGraph $ withFreshLabels $ \l ->
+         spliceOO g blocks = graphOfAGraph $ withFresh $ \l ->
            A (return g) <*> mkBranch l |*><*| A (return blocks) |*><*| mkLabel l
  
  -- | For some graph-construction operations and some optimizations,
@@@ -182,19 -184,19 +186,19 @@@ class IfThenElseable x wher
    -- The condition takes as arguments labels on the true-false branch
    -- and returns a single-entry, two-exit graph which exits to 
    -- the two labels.
 -  mkIfThenElse :: HooplNode n
 -               => (Label -> Label -> AGraph n O C) -- ^ branch condition
 -               -> AGraph n O x   -- ^ code in the "then" branch
 -               -> AGraph n O x   -- ^ code in the "else" branch 
 -               -> AGraph n O x   -- ^ resulting if-then-else construct
 +  mkIfThenElse :: (HooplNode n, HooplMonad m)
 +               => (Label -> Label -> AGraph n O C) -- ^ branch condition
 +               -> AGraph n O x   -- ^ code in the "then" branch
 +               -> AGraph n O x   -- ^ code in the "else" branch 
 +               -> AGraph n O x   -- ^ resulting if-then-else construct
  
 -mkWhileDo    :: HooplNode n
 -             => (Label -> Label -> AGraph n O C) -- ^ loop condition
 -             -> AGraph n O O -- ^ body of the loop
 -             -> AGraph n O O -- ^ the final while loop
 +mkWhileDo    :: (HooplNode n, HooplMonad m)
 +             => (Label -> Label -> AGraph n O C) -- ^ loop condition
 +             -> AGraph n O O -- ^ body of the loop
 +             -> AGraph n O O -- ^ the final while loop
  
  instance IfThenElseable O where
-   mkIfThenElse cbranch tbranch fbranch = withFreshLabels $ \(endif, ltrue, lfalse) ->
+   mkIfThenElse cbranch tbranch fbranch = withFresh $ \(endif, ltrue, lfalse) ->
      cbranch ltrue lfalse |*><*|
        mkLabel ltrue  <*> tbranch <*> mkBranch endif |*><*|
        mkLabel lfalse <*> fbranch <*> mkBranch endif |*><*|
@@@ -240,9 -242,9 +244,9 @@@ instance (Uniques u1, Uniques u2, Uniqu
  -- deprecated legacy functions
  
  {-# DEPRECATED addEntrySeq, addExitSeq, unionBlocks "use |*><*| instead" #-}
- addEntrySeq    :: Monad m => AGraph m n O C -> AGraph m n C x -> AGraph m n O x
- addExitSeq     :: Monad m => AGraph m n e C -> AGraph m n C O -> AGraph m n e O
- unionBlocks    :: Monad m => AGraph m n C C -> AGraph m n C C -> AGraph m n C C
 -addEntrySeq    :: Edges n => AGraph n O C -> AGraph n C x -> AGraph n O x
 -addExitSeq     :: Edges n => AGraph n e C -> AGraph n C O -> AGraph n e O
 -unionBlocks    :: Edges n => AGraph n C C -> AGraph n C C -> AGraph n C C
++addEntrySeq :: (Monad m, Edges n) => AGraph m n O C -> AGraph m n C x -> AGraph m n O x
++addExitSeq  :: (Monad m, Edges n) => AGraph m n e C -> AGraph m n C O -> AGraph m n e O
++unionBlocks :: (Monad m, Edges n) => AGraph m n C C -> AGraph m n C C -> AGraph m n C C
  
  addEntrySeq = (|*><*|)
  addExitSeq  = (|*><*|)
index 0000000,2431a76..b1b0bf3
mode 000000,100644..100644
--- /dev/null
@@@ -1,0 -1,28 +1,22 @@@
 -  ( Unique, uniqOfInt, intOfUniq
 -  , allUniques {- to be used only by the Fuel monad -}
+ module Compiler.Hoopl.Unique
 -import qualified Data.IntMap as M
 -import qualified Data.IntSet as S
 -
++  ( Unique, intOfUniq, uniqOfInt
++  , HooplMonad(..)
+   )
+ where
 -data Unique = Unique {-# UNPACK #-} !Int
+ -----------------------------------------------------------------------------
+ --            Unique
+ -----------------------------------------------------------------------------
 -instance Show Unique where
 -  show (Unique n) = show n
 -
++data Unique = Unique { intOfUniq ::  {-# UNPACK #-} !Int }
+   deriving (Eq, Ord)
 -intOfUniq :: Unique -> Int
 -intOfUniq (Unique key) = key
+ uniqOfInt :: Int -> Unique
+ uniqOfInt = Unique
 -allUniques :: [Unique]
 -allUniques = map Unique [1..]
++instance Show Unique where
++  show (Unique n) = show n
++class Monad m => HooplMonad m where
++  freshUnique :: m Unique
Simple merge
diff --cc src/hoopl.cabal
@@@ -16,10 -16,10 +16,11 @@@ Extra-source-files:  README, hoopl.pdf
  Library
    Build-Depends:     base >= 3 && < 5, containers
    Exposed-modules:   Compiler.Hoopl,
 -                       Compiler.Hoopl.Passes.Dominator,
 -                       Compiler.Hoopl.DataflowFold,
 -                       Compiler.Hoopl.Pointed,
 +                     Compiler.Hoopl.Passes.Dominator,
 +--                       Compiler.Hoopl.DataflowFold,
 +--                       Compiler.Hoopl.OldDataflow,
 +                       Compiler.Hoopl.Pointed
+                        Compiler.Hoopl.GHC
    Other-modules:     Compiler.Hoopl.GraphUtil,
                       -- GraphUtil should *never* be seen by clients.
                       -- The remaining modules are hidden *provisionally*