hoopl 3.8.6.0 → 3.8.7.0

raw patch · 46 files changed

+3385/−3292 lines, 46 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES +7/−0
• Compiler/Hoopl.hs +0/−37
• Compiler/Hoopl/Checkpoint.hs +0/−17
• Compiler/Hoopl/Collections.hs +0/−85
• Compiler/Hoopl/Combinators.hs +0/−182
• Compiler/Hoopl/Dataflow.hs +0/−809
• Compiler/Hoopl/Debug.hs +0/−103
• Compiler/Hoopl/Fuel.hs +0/−105
• Compiler/Hoopl/GHC.hs +0/−24
• Compiler/Hoopl/Graph.hs +0/−119
• Compiler/Hoopl/GraphUtil.hs +0/−124
• Compiler/Hoopl/Label.hs +0/−104
• Compiler/Hoopl/MkGraph.hs +0/−252
• Compiler/Hoopl/Passes/DList.hs +0/−45
• Compiler/Hoopl/Passes/Dominator.hs +0/−130
• Compiler/Hoopl/Pointed.hs +0/−147
• Compiler/Hoopl/Shape.hs +0/−50
• Compiler/Hoopl/Show.hs +0/−41
• Compiler/Hoopl/Unique.hs +0/−134
• Compiler/Hoopl/Util.hs +0/−263
• Compiler/Hoopl/Wrappers.hs +0/−7
• Compiler/Hoopl/XUtil.hs +0/−490
• README +18/−23
• hoopl.cabal +3/−1
• hoopl.pdf binary
• src/Compiler/Hoopl.hs +37/−0
• src/Compiler/Hoopl/Checkpoint.hs +17/−0
• src/Compiler/Hoopl/Collections.hs +85/−0
• src/Compiler/Hoopl/Combinators.hs +232/−0
• src/Compiler/Hoopl/Dataflow.hs +821/−0
• src/Compiler/Hoopl/Debug.hs +103/−0
• src/Compiler/Hoopl/Fuel.hs +105/−0
• src/Compiler/Hoopl/GHC.hs +24/−0
• src/Compiler/Hoopl/Graph.hs +119/−0
• src/Compiler/Hoopl/GraphUtil.hs +124/−0
• src/Compiler/Hoopl/Label.hs +104/−0
• src/Compiler/Hoopl/MkGraph.hs +252/−0
• src/Compiler/Hoopl/Passes/DList.hs +45/−0
• src/Compiler/Hoopl/Passes/Dominator.hs +130/−0
• src/Compiler/Hoopl/Pointed.hs +147/−0
• src/Compiler/Hoopl/Shape.hs +50/−0
• src/Compiler/Hoopl/Show.hs +41/−0
• src/Compiler/Hoopl/Unique.hs +138/−0
• src/Compiler/Hoopl/Util.hs +268/−0
• src/Compiler/Hoopl/Wrappers.hs +7/−0
• src/Compiler/Hoopl/XUtil.hs +508/−0

@@ -1,3 +1,10 @@+3.8.7.0+  Works with GHC 7 (thanks Edward Yang)+  cabal sdist now sort of works (and is added to validate)++3.8.6.0+  Matches the camera-ready Haskell'10 paper+ 3.8.1.0    Major reorganization per simonpj visit to Tufts 20 April 2010

@@ -1,37 +0,0 @@-module Compiler.Hoopl-  ( module Compiler.Hoopl.Graph-  , 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-  , module Compiler.Hoopl.Combinators-  , module Compiler.Hoopl.Fuel-  , module Compiler.Hoopl.Unique-  , module Compiler.Hoopl.Util-  , module Compiler.Hoopl.Debug-  , module Compiler.Hoopl.Show-  )-where--import Compiler.Hoopl.Checkpoint-import Compiler.Hoopl.Collections-import Compiler.Hoopl.Combinators-import Compiler.Hoopl.Dataflow hiding ( wrapFR, wrapFR2, wrapBR, wrapBR2-                                      )-import Compiler.Hoopl.Debug-import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel, FuelMonadT)-import Compiler.Hoopl.Graph hiding -   ( Body-   , BCat, BHead, BTail, BClosed -- OK to expose BFirst, BMiddle, BLast-   )-import Compiler.Hoopl.Graph (Body)-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 (uniqueToInt)-import Compiler.Hoopl.XUtil

@@ -1,17 +0,0 @@-{-# 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 () -

@@ -1,85 +0,0 @@-{- Baseclasses for Map-like and Set-like collections inspired by containers. -}--{-# LANGUAGE TypeFamilies #-}-module Compiler.Hoopl.Collections ( IsSet(..)-                                  , setInsertList, setDeleteList, setUnions-                                  , IsMap(..)-                                  , mapInsertList, mapDeleteList, mapUnions-                                  ) where--import Data.List (foldl', foldl1')--class IsSet set where-  type ElemOf set--  setNull :: set -> Bool-  setSize :: set -> Int-  setMember :: ElemOf set -> set -> Bool--  setEmpty :: set-  setSingleton :: ElemOf set -> set-  setInsert :: ElemOf set -> set -> set-  setDelete :: ElemOf set -> set -> set--  setUnion :: set -> set -> set-  setDifference :: set -> set -> set-  setIntersection :: set -> set -> set-  setIsSubsetOf :: set -> set -> Bool--  setFold :: (ElemOf set -> b -> b) -> b -> set -> b--  setElems :: set -> [ElemOf set]-  setFromList :: [ElemOf set] -> set---- Helper functions for IsSet class-setInsertList :: IsSet set => [ElemOf set] -> set -> set-setInsertList keys set = foldl' (flip setInsert) set keys--setDeleteList :: IsSet set => [ElemOf set] -> set -> set-setDeleteList keys set = foldl' (flip setDelete) set keys--setUnions :: IsSet set => [set] -> set-setUnions [] = setEmpty-setUnions sets = foldl1' setUnion sets---class IsMap map where-  type KeyOf map--  mapNull :: map a -> Bool-  mapSize :: map a -> Int-  mapMember :: KeyOf map -> map a -> Bool-  mapLookup :: KeyOf map -> map a -> Maybe a-  mapFindWithDefault :: a -> KeyOf map -> map a -> a--  mapEmpty :: map a-  mapSingleton :: KeyOf map -> a -> map a-  mapInsert :: KeyOf map -> a -> map a -> map a-  mapDelete :: KeyOf map -> map a -> map a--  mapUnion :: map a -> map a -> map a-  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a-  mapDifference :: map a -> map a -> map a-  mapIntersection :: map a -> map a -> map a-  mapIsSubmapOf :: Eq a => map a -> map a -> Bool--  mapMap :: (a -> b) -> map a -> map b-  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b-  mapFold :: (a -> b -> b) -> b -> map a -> b-  mapFoldWithKey :: (KeyOf map -> a -> b -> b) -> b -> map a -> b--  mapElems :: map a -> [a]-  mapKeys :: map a -> [KeyOf map]-  mapToList :: map a -> [(KeyOf map, a)]-  mapFromList :: [(KeyOf map, a)] -> map a---- Helper functions for IsMap class-mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a-mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs--mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a-mapDeleteList keys map = foldl' (flip mapDelete) map keys--mapUnions :: IsMap map => [map a] -> map a-mapUnions [] = mapEmpty-mapUnions maps = foldl1' mapUnion maps

@@ -1,182 +0,0 @@-{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables, GADTs #-}--module Compiler.Hoopl.Combinators-  ( thenFwdRw-  , deepFwdRw3, deepFwdRw, iterFwdRw-  , thenBwdRw-  , deepBwdRw3, deepBwdRw, iterBwdRw-  , pairFwd, pairBwd, pairLattice-  )--where--import Control.Monad-import Data.Maybe--import Compiler.Hoopl.Collections-import Compiler.Hoopl.Dataflow-import Compiler.Hoopl.Fuel-import Compiler.Hoopl.Graph (Graph, C, O, Shape(..))-import Compiler.Hoopl.Label--------------------------------------------------------------------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-deepFwdRw f = deepFwdRw3 f f f---- N.B. rw3, rw3', and rw3a are triples of functions.--- But rw and rw' are single functions.--- @ start comb1.tex-thenFwdRw :: Monad m -          => FwdRewrite m n f -          -> FwdRewrite m n f -          -> FwdRewrite m n f--- @ end comb1.tex-thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3'- where-  thenrw rw rw' n f = rw n f >>= fwdRes-     where fwdRes Nothing   = rw' n f-           fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr---- @ start iterf.tex-iterFwdRw :: Monad m -          => FwdRewrite m n f -          -> FwdRewrite m n f--- @ end iterf.tex-iterFwdRw rw3 = wrapFR iter rw3- where iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n-       _iter = frewrite_cps (return . Just . fadd_rw (iterFwdRw rw3)) (return Nothing)---- | Function inspired by 'rew' in the paper-frewrite_cps :: Monad m-             => ((Graph n e x, FwdRewrite m n f) -> m a)-             -> m a-             -> (forall e x . n e x -> f -> m (Maybe (Graph n e x, FwdRewrite m n f)))-             -> n e x-             -> f-             -> m a-frewrite_cps j n rw node f =-    do mg <- rw node f-       case mg of Nothing -> n-                  Just gr -> j gr------ | Function inspired by 'add' in the paper-fadd_rw :: Monad m-       => FwdRewrite m n f-       -> (Graph n e x, FwdRewrite m n f)-       -> (Graph n e x, FwdRewrite m n f)-fadd_rw rw2 (g, rw1) = (g, rw1 `thenFwdRw` rw2)--------------------------------------------------------------------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-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 = wrapBR2 f rw1 rw2-  where f _ rw1 rw2' n f = do-          res1 <- rw1 n f-          case res1 of-            Nothing -> rw2' n f-            Just gr -> return $ Just $ badd_rw rw2 gr--iterBwdRw :: Monad m => BwdRewrite m n f -> BwdRewrite m n f-iterBwdRw rw = wrapBR f rw-  where f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f)---- | Function inspired by 'add' in the paper-badd_rw :: Monad m-       => BwdRewrite m n f-       -> (Graph n e x, BwdRewrite m n f)-       -> (Graph n e x, BwdRewrite m n f)-badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2)----- @ start pairf.tex-pairFwd :: Monad m-        => FwdPass m n f-        -> FwdPass m n f' -        -> FwdPass m n (f, f')--- @ end pairf.tex-pairFwd pass1 pass2 = FwdPass lattice transfer rewrite-  where-    lattice = pairLattice (fp_lattice pass1) (fp_lattice pass2)-    transfer = mkFTransfer3 (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) = mapMapWithKey withfb2 fb1-          where fb1 = t1 n f1-                fb2 = t2 n f2-                withfb2 l f = (f, fromMaybe bot2 $ lookupFact l fb2)-                bot2 = fact_bot (fp_lattice pass2)-        (tf1, tm1, tl1) = getFTransfer3 (fp_transfer pass1)-        (tf2, tm2, tl2) = getFTransfer3 (fp_transfer pass2)-    rewrite = lift fst (fp_rewrite pass1) `thenFwdRw` lift snd (fp_rewrite pass2) -      where-        lift proj = wrapFR project-          where project rw = \n pair -> liftM (liftM repair) $ rw n (proj pair)-                repair (g, rw') = (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-  where-    lattice = pairLattice (bp_lattice pass1) (bp_lattice pass2)-    transfer = mkBTransfer3 (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 $ mapMap fst fb, t2 n $ mapMap snd fb)-        (tf1, tm1, tl1) = getBTransfer3 (bp_transfer pass1)-        (tf2, tm2, tl2) = getBTransfer3 (bp_transfer pass2)-    rewrite = lift fst (bp_rewrite pass1) `thenBwdRw` lift snd (bp_rewrite pass2) -      where-       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 (Graph n e x, BwdRewrite m n f1)))-               -> (n e x ->-                       Fact x (f,f') -> m (Maybe (Graph n e x, BwdRewrite m n (f,f'))))-              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 (g, rw') = (g, lift proj rw')-                -- XXX specialize repair so that the cost-                -- of discriminating is one per combinator not one-                -- per rewrite--pairLattice :: forall f f' .-               DataflowLattice f -> DataflowLattice f' -> DataflowLattice (f, f')-pairLattice l1 l2 =-  DataflowLattice-    { fact_name = fact_name l1 ++ " x " ++ fact_name l2-    , fact_bot  = (fact_bot l1, fact_bot l2)-    , fact_join = join-    }-  where-    join lbl (OldFact (o1, o2)) (NewFact (n1, n2)) = (c', (f1, f2))-      where (c1, f1) = fact_join l1 lbl (OldFact o1) (NewFact n1)-            (c2, f2) = fact_join l2 lbl (OldFact o2) (NewFact n2)-            c' = case (c1, c2) of-                   (NoChange, NoChange) -> NoChange-                   _                    -> SomeChange

@@ -1,809 +0,0 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-}--module Compiler.Hoopl.Dataflow-  ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact, mkFactBase-  , ChangeFlag(..), changeIf-  , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3-  -- * Respecting Fuel--  -- $fuel-  , FwdRewrite,  mkFRewrite,  mkFRewrite3,  getFRewrite3, noFwdRewrite-  , wrapFR, wrapFR2-  , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3-  , wrapBR, wrapBR2-  , BwdRewrite,  mkBRewrite,  mkBRewrite3,  getBRewrite3, noBwdRewrite-  , analyzeAndRewriteFwd,  analyzeAndRewriteBwd-  )-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-                                           -- and include definition in paper-import qualified Compiler.Hoopl.GraphUtil as U-import Compiler.Hoopl.Label-import Compiler.Hoopl.Util----------------------------------------------------------------------------------              DataflowLattice--------------------------------------------------------------------------------data DataflowLattice a = DataflowLattice  - { fact_name       :: String          -- Documentation- , fact_bot        :: a               -- Lattice bottom element- , fact_join       :: JoinFun a       -- Lattice join plus change flag-                                      -- (changes iff result > old fact)- }--- ^ A transfer function might want to use the logging flag--- to control debugging, as in for example, it updates just one element--- in a big finite map.  We don't want Hoopl to show the whole fact,--- and only the transfer function knows exactly what changed.--type JoinFun a = Label -> OldFact a -> NewFact a -> (ChangeFlag, a)-  -- the label argument is for debugging purposes only-newtype OldFact a = OldFact a-newtype NewFact a = NewFact a--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--------------------------------------------------------------------------------data FwdPass m n f-  = FwdPass { fp_lattice  :: DataflowLattice f-            , fp_transfer :: FwdTransfer n f-            , fp_rewrite  :: FwdRewrite m n f }--newtype FwdTransfer n f -  = FwdTransfer3 { getFTransfer3 ::-                     ( n C O -> f -> f-                     , n O O -> f -> f-                     , n O C -> f -> FactBase f-                     ) }--newtype FwdRewrite m n f   -- see Note [Respects Fuel]-  = FwdRewrite3 { getFRewrite3 ::-                    ( n C O -> f -> m (Maybe (Graph n C O, FwdRewrite m n f))-                    , n O O -> f -> m (Maybe (Graph n O O, FwdRewrite m n f))-                    , n O C -> f -> m (Maybe (Graph n O C, FwdRewrite m n f))-                    ) }--wrapFR :: (forall e x. (n  e x -> f  -> m  (Maybe (Graph n  e x, FwdRewrite m  n  f )))-                    -> (n' e x -> f' -> m' (Maybe (Graph n' e x, FwdRewrite m' n' f')))-          )-            -- ^ 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 (Graph n1 e x, FwdRewrite m1 n1 f1))) ->-                   (n2 e x -> f2 -> m2 (Maybe (Graph n2 e x, FwdRewrite m2 n2 f2))) ->-                   (n3 e x -> f3 -> m3 (Maybe (Graph n3 e x, FwdRewrite m3 n3 f3)))-     )-            -- ^ 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)-             -> FwdTransfer n f-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)))-            -> (n O C -> f -> m (Maybe (Graph n O C)))-            -> FwdRewrite m n f-mkFRewrite3 f m l = FwdRewrite3 (lift f, lift m, lift l)-  where lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact)-        asRew g = (g, noFwdRewrite)--noFwdRewrite :: Monad m => FwdRewrite m n f-noFwdRewrite = FwdRewrite3 (noRewrite, noRewrite, noRewrite)--noRewrite :: Monad m => a -> b -> m (Maybe c)-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---type family   Fact x f :: *-type instance Fact C f = FactBase f-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. (CheckpointMonad m, NonLocal n, LabelsPtr entries)-   => FwdPass m n f-   -> MaybeC e entries-   -> Graph n e x -> Fact e f-   -> m (Graph n e x, FactBase f, MaybeO x f)-analyzeAndRewriteFwd pass entries g f =-  do (rg, fout) <- arfGraph pass (fmap targetLabels entries) g f-     let (g', fb) = normalizeGraph rg-     return (g', fb, distinguishedExitFact g' fout)--distinguishedExitFact :: forall n e x f . Graph n e x -> Fact x f -> MaybeO x f-distinguishedExitFact g f = maybe g-    where maybe :: Graph n e x -> MaybeO x f-          maybe GNil       = JustO f-          maybe (GUnit {}) = JustO f-          maybe (GMany _ _ x) = case x of NothingO -> NothingO-                                          JustO _  -> JustO f---------------------------------------------------------------------       Forward Implementation-------------------------------------------------------------------type Entries e = MaybeC e [Label]--arfGraph :: forall m n f e x .-            (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-    {- nested type synonyms would be so lovely here -    type ARF  thing = forall e x . thing e x -> f        -> m (DG f n e x, Fact x f)-    type ARFX thing = forall e x . thing e x -> Fact e f -> m (DG f n e x, Fact x f)-    -}-    graph ::              Graph n e x -> Fact e f -> m (DG f n e x, Fact x f)--- @ start block.tex -2-    block :: forall e x . -             Block n e x -> f -> m (DG f n e x, Fact x f)--- @ end block.tex--- @ start node.tex -4-    node :: forall e x . (ShapeLifter e x) -         => n e x -> f -> m (DG f n e x, Fact x f)--- @ end node.tex--- @ start bodyfun.tex-    body  :: [Label] -> LabelMap (Block n C C)-          -> Fact C f -> m (DG f n C C, Fact C f)--- @ end bodyfun.tex-                    -- Outgoing factbase is restricted to Labels *not* in-                    -- in the Body; the facts for Labels *in*-                    -- the Body are in the 'DG f n C C'--- @ start cat.tex -2-    cat :: forall e a x f1 f2 f3. -           (f1 -> m (DG f n e a, f2))-        -> (f2 -> m (DG f n a x, f3))-        -> (f1 -> m (DG f n e x, f3))--- @ end cat.tex--    graph GNil            = \f -> return (dgnil, f)-    graph (GUnit blk)     = block blk-    graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x-     where-      ebcat :: MaybeO e (Block n O C) -> Body n -> Fact e f -> m (DG f n e C, Fact C f)-      exit  :: MaybeO x (Block n C O)           -> Fact C f -> m (DG f n C x, Fact x f)-      exit (JustO blk) = arfx block blk-      exit NothingO    = \fb -> return (dgnilC, fb)-      ebcat entry bdy = c entries entry-       where c :: MaybeC e [Label] -> MaybeO e (Block n O C)-                -> Fact e f -> m (DG f n e C, Fact C f)-             c NothingC (JustO entry)   = block entry `cat` body (successors entry) bdy-             c (JustC entries) NothingO = body entries bdy-             c _ _ = error "bogus GADT pattern match failure"--    -- Lift from nodes to blocks--- @ start block.tex -2-    block (BFirst  n)  = node n-    block (BMiddle n)  = node n-    block (BLast   n)  = node n-    block (BCat b1 b2) = block b1 `cat` block b2--- @ end block.tex-    block (BHead h n)  = block h  `cat` node n-    block (BTail n t)  = node  n  `cat` block t-    block (BClosed h t)= block h  `cat` block t---- @ start node.tex -4-    node n f-     = do { grw <- frewrite pass n f-          ; case grw of-              Nothing -> return ( singletonDG f n-                                , ftransfer pass n f )-              Just (g, rw) ->-                  let pass' = pass { fp_rewrite = rw }-                      f'    = fwdEntryFact n f-                  in  arfGraph pass' (fwdEntryLabel n) g f' }---- @ end node.tex--    -- | Compose fact transformers and concatenate the resulting-    -- rewritten graphs.-    {-# INLINE cat #-} --- @ start cat.tex -2-    cat ft1 ft2 f = do { (g1,f1) <- ft1 f-                       ; (g2,f2) <- ft2 f1-                       ; return (g1 `dgSplice` g2, f2) }--- @ end cat.tex-    arfx :: forall thing x .-            NonLocal thing-         => (thing C x ->        f -> m (DG f n C x, Fact x f))-         -> (thing C x -> Fact C f -> m (DG f n C x, Fact x f))-    arfx arf thing fb = -      arf thing $ fromJust $ lookupFact (entryLabel thing) $ joinInFacts lattice fb-     where lattice = fp_lattice pass-     -- joinInFacts adds debugging information---                    -- Outgoing factbase is restricted to Labels *not* in-                    -- in the Body; the facts for Labels *in*-                    -- 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-      where-        blocks  = forwardBlockList entries blockmap-        lattice = fp_lattice pass-        do_block b fb = block b entryFact-          where entryFact = getFact lattice (entryLabel b) fb--- @ end bodyfun.tex----- Join all the incoming facts with bottom.--- 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 (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)-                 => entry -> Body n -> [Block n C C]--- This produces a list of blocks in order suitable for forward analysis,--- along with the list of Labels it may depend on for facts.-forwardBlockList entries blks = postorder_dfs_from blks entries----------------------------------------------------------------------------------              Backward analysis and rewriting: the interface--------------------------------------------------------------------------------data BwdPass m n f-  = BwdPass { bp_lattice  :: DataflowLattice f-            , bp_transfer :: BwdTransfer n f-            , bp_rewrite  :: BwdRewrite m n f }--newtype BwdTransfer n f -  = BwdTransfer3 { getBTransfer3 ::-                     ( n C O -> f          -> f-                     , n O O -> f          -> f-                     , n O C -> FactBase f -> f-                     ) }-newtype BwdRewrite m n f -  = BwdRewrite3 { getBRewrite3 ::-                    ( n C O -> f          -> m (Maybe (Graph n C O, BwdRewrite m n f))-                    , n O O -> f          -> m (Maybe (Graph n O O, BwdRewrite m n f))-                    , n O C -> FactBase f -> m (Maybe (Graph n O C, BwdRewrite m n f))-                    ) }--wrapBR :: (forall e x .-                Shape x -             -> (n  e x -> Fact x f  -> m  (Maybe (Graph n  e x, BwdRewrite m  n  f )))-             -> (n' e x -> Fact x f' -> m' (Maybe (Graph n' e x, BwdRewrite m' n' f')))-          )-            -- ^ 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 (Graph n1 e x, BwdRewrite m1 n1 f1)))-            -> (n2 e x -> Fact x f2 -> m2 (Maybe (Graph n2 e x, BwdRewrite m2 n2 f2)))-            -> (n3 e x -> Fact x f3 -> m3 (Maybe (Graph n3 e x, BwdRewrite m3 n3 f3))))-            -- ^ 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-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)))-            -> (n O C -> FactBase f -> m (Maybe (Graph n O C)))-            -> BwdRewrite m n f-mkBRewrite3 f m l = BwdRewrite3 (lift f, lift m, lift l)-  where lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact)-        asRew g = (g, noBwdRewrite)--noBwdRewrite :: Monad m => BwdRewrite m n f-noBwdRewrite = BwdRewrite3 (noRewrite, noRewrite, noRewrite)---- | 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 = mkBRewrite3 f f f-----------------------------------------------------------------------------------              Backward implementation--------------------------------------------------------------------------------arbGraph :: forall m n f e x .-            (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-    {- nested type synonyms would be so lovely here -    type ARB  thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, f)-    type ARBX thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, Fact e f)-    -}-    graph ::              Graph n e x -> Fact x f -> m (DG f n e x, Fact e f)-    block :: forall e x . Block n e x -> Fact x f -> m (DG f n e x, f)-    node  :: forall e x . (ShapeLifter e x) -                       => n e x       -> Fact x f -> m (DG f n e x, f)-    body  :: [Label] -> Body n -> Fact C f -> m (DG f n C C, Fact C f)-    cat :: forall e a x info info' info''.-           (info' -> m (DG f n e a, info''))-        -> (info  -> m (DG f n a x, info'))-        -> (info  -> m (DG f n e x, info''))--    graph GNil            = \f -> return (dgnil, f)-    graph (GUnit blk)     = block blk-    graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x-     where-      ebcat :: MaybeO e (Block n O C) -> Body n -> Fact C f -> m (DG f n e C, Fact e f)-      exit  :: MaybeO x (Block n C O)           -> Fact x f -> m (DG f n C x, Fact C f)-      exit (JustO blk) = arbx block blk-      exit NothingO    = \fb -> return (dgnilC, fb)-      ebcat entry bdy = c entries entry-       where c :: MaybeC e [Label] -> MaybeO e (Block n O C)-                -> Fact C f -> m (DG f n e C, Fact e f)-             c NothingC (JustO entry)   = block entry `cat` body (successors entry) bdy-             c (JustC entries) NothingO = body entries bdy-             c _ _ = error "bogus GADT pattern match failure"--    -- Lift from nodes to blocks-    block (BFirst  n)  = node n-    block (BMiddle n)  = node n-    block (BLast   n)  = node n-    block (BCat b1 b2) = block b1 `cat` block b2-    block (BHead h n)  = block h  `cat` node n-    block (BTail n t)  = node  n  `cat` block t-    block (BClosed h t)= block h  `cat` block t--    node n f-      = do { bwdres <- brewrite pass n f-           ; case bwdres of-               Nothing -> return (singletonDG entry_f n, entry_f)-                            where entry_f = btransfer pass n f-               Just (g, rw) ->-                          do { let pass' = pass { bp_rewrite = rw }-                             ; (g, f) <- arbGraph pass' (fwdEntryLabel n) g f-                             ; return (g, bwdEntryFact (bp_lattice pass) n f)} }--    -- | Compose fact transformers and concatenate the resulting-    -- rewritten graphs.-    {-# INLINE cat #-} -    cat ft1 ft2 f = do { (g2,f2) <- ft2 f-                       ; (g1,f1) <- ft1 f2-                       ; return (g1 `dgSplice` g2, f1) }--    arbx :: forall thing x .-            NonLocal thing-         => (thing C x -> Fact x f -> m (DG f n C x, f))-         -> (thing C x -> Fact x f -> m (DG f n C x, Fact C f))--    arbx arb thing f = do { (rg, f) <- arb thing f-                          ; let fb = joinInFacts (bp_lattice pass) $-                                     mapSingleton (entryLabel thing) f-                          ; return (rg, fb) }-     -- joinInFacts adds debugging information--                    -- Outgoing factbase is restricted to Labels *not* in-                    -- 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-      where-        blocks = backwardBlockList entries blockmap-        do_block b f = do (g, f) <- block b f-                          return (g, mapSingleton (entryLabel b) f)---backwardBlockList :: (LabelsPtr entries, NonLocal n) => entries -> Body n -> [Block n C C]--- This produces a list of blocks in order suitable for backward analysis,--- along with the list of Labels it may depend on for facts.-backwardBlockList entries body = reverse $ forwardBlockList entries body--{---The forward and backward cases are not dual.  In the forward case, the-entry points are known, and one simply traverses the body blocks from-those points.  In the backward case, something is known about the exit-points, but this information is essentially useless, because we don't-actually have a dual graph (that is, one with edges reversed) to-compute with.  (Even if we did have a dual graph, it would not avail-us---a backward analysis must include reachable blocks that don't-reach the exit, as in a procedure that loops forever and has side-effects.)---}----- | if the graph being analyzed is open at the exit, I don't---   quite understand the implications of possible other exits-analyzeAndRewriteBwd-   :: (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)-analyzeAndRewriteBwd pass entries g f =-  do (rg, fout) <- arbGraph pass (fmap targetLabels entries) g f-     let (g', fb) = normalizeGraph rg-     return (g', fb, distinguishedEntryFact g' fout)--distinguishedEntryFact :: forall n e x f . Graph n e x -> Fact e f -> MaybeO e f-distinguishedEntryFact g f = maybe g-    where maybe :: Graph n e x -> MaybeO e f-          maybe GNil       = JustO f-          maybe (GUnit {}) = JustO f-          maybe (GMany e _ _) = case e of NothingO -> NothingO-                                          JustO _  -> JustO f----------------------------------------------------------------------------------      fixpoint: finding fixed points--------------------------------------------------------------------------------- @ start txfb.tex-data TxFactBase n f-  = TxFB { tfb_fbase :: FactBase f-         , tfb_rg    :: DG f n C C -- Transformed blocks-         , tfb_cha   :: ChangeFlag-         , tfb_lbls  :: LabelSet }--- @ end txfb.tex-     -- See Note [TxFactBase invariants]--- @ start update.tex-updateFact :: DataflowLattice f -> LabelSet-           -> Label -> f -> (ChangeFlag, FactBase f)-           -> (ChangeFlag, FactBase f)--- See Note [TxFactBase change flag]-updateFact lat lbls lbl new_fact (cha, fbase)-  | NoChange <- cha2     = (cha,        fbase)-  | lbl `setMember` lbls = (SomeChange, new_fbase)-  | otherwise            = (cha,        new_fbase)-  where-    (cha2, res_fact) -- Note [Unreachable blocks]-       = case lookupFact lbl fbase of-           Nothing -> (SomeChange, new_fact_debug)  -- Note [Unreachable blocks]-           Just old_fact -> join old_fact-         where join old_fact = -                 fact_join lat lbl-                   (OldFact old_fact) (NewFact new_fact)-               (_, new_fact_debug) = join (fact_bot lat)-    new_fbase = mapInsert lbl res_fact fbase--- @ end update.tex---{---- this doesn't work because it can't be implemented-class Monad m => FixpointMonad m where-  observeChangedFactBase :: m (Maybe (FactBase f)) -> Maybe (FactBase f)--}---- @ start fptype.tex-data Direction = Fwd | Bwd-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))- -> [Block n C C]- -> (Fact C f -> m (DG f n C C, Fact C f))--- @ end fptype.tex--- @ start fpimp.tex-fixpoint direction lat do_block blocks init_fbase-  = do { tx_fb <- loop init_fbase-       ; return (tfb_rg tx_fb, -                 map (fst . fst) tagged_blocks -                    `mapDeleteList` tfb_fbase tx_fb ) }-    -- The successors of the Graph are the the Labels -    -- for which we have facts and which are *not* in-    -- the blocks of the graph-  where-    tagged_blocks = map tag blocks-    is_fwd = case direction of { Fwd -> True; -                                 Bwd -> False }-    tag b = ((entryLabel b, b), -             if is_fwd then [entryLabel b] -                        else successors b)-     -- 'tag' adds the in-labels of the block; -     -- see Note [TxFactBase invairants]--    tx_blocks :: [((Label, Block n C C), [Label])]   -- I do not understand this type-              -> TxFactBase n f -> m (TxFactBase n f)-    tx_blocks []              tx_fb = return tx_fb-    tx_blocks (((lbl,blk), in_lbls):bs) tx_fb -      = tx_block lbl blk in_lbls tx_fb >>= tx_blocks bs-     -- "in_lbls" == Labels the block may -     --                 _depend_ upon for facts--    tx_block :: Label -> Block n C C -> [Label]-             -> TxFactBase n f -> m (TxFactBase n f)-    tx_block lbl blk in_lbls -        tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls-                    , tfb_rg = blks, tfb_cha = cha })-      | is_fwd && not (lbl `mapMember` fbase)-      = return (tx_fb {tfb_lbls = lbls'})       -- Note [Unreachable blocks]-      | otherwise-      = do { (rg, out_facts) <- do_block blk fbase-           ; let (cha', fbase') = mapFoldWithKey-                                  (updateFact lat lbls) -                                  (cha,fbase) out_facts-           ; return $-               TxFB { tfb_lbls  = lbls'-                    , tfb_rg    = rg `dgSplice` blks-                    , tfb_fbase = fbase'-                    , tfb_cha = cha' } }-      where-        lbls' = lbls `setUnion` setFromList in_lbls-        --    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) } }--- @ end fpimp.tex           ---{-  Note [TxFactBase invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The TxFactBase is used only during a fixpoint iteration (or "sweep"),-and accumulates facts (and the transformed code) during the fixpoint-iteration.--* tfb_fbase increases monotonically, across all sweeps--* At the beginning of each sweep-      tfb_cha  = NoChange-      tfb_lbls = {}--* During each sweep we process each block in turn.  Processing a block-  is done thus:-    1.  Read from tfb_fbase the facts for its entry label (forward)-        or successors labels (backward)-    2.  Transform those facts into new facts for its successors (forward)-        or entry label (backward)-    3.  Augment tfb_fbase with that info-  We call the labels read in step (1) the "in-labels" of the sweep--* The field tfb_lbls is the set of in-labels of all blocks that have-  been processed so far this sweep, including the block that is-  currently being processed.  tfb_lbls is initialised to {}.  It is a-  subset of the Labels of the *original* (not transformed) blocks.--* The tfb_cha field is set to SomeChange iff we decide we need to-  perform another iteration of the fixpoint loop. It is initialsed to NoChange.--  Specifically, we set tfb_cha to SomeChange in step (3) iff-    (a) The fact in tfb_fbase for a block L changes-    (b) L is in tfb_lbls-  Reason: until a label enters the in-labels its accumuated fact in tfb_fbase-  has not been read, hence cannot affect the outcome--Note [Unreachable blocks]-~~~~~~~~~~~~~~~~~~~~~~~~~-A block that is not in the domain of tfb_fbase is "currently unreachable".-A currently-unreachable block is not even analyzed.  Reason: consider -constant prop and this graph, with entry point L1:-  L1: x:=3; goto L4-  L2: x:=4; goto L4-  L4: if x>3 goto L2 else goto L5-Here L2 is actually unreachable, but if we process it with bottom input fact,-we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.--* If a currently-unreachable block is not analyzed, then its rewritten-  graph will not be accumulated in tfb_rg.  And that is good:-  unreachable blocks simply do not appear in the output.--* Note that clients must be careful to provide a fact (even if bottom)-  for each entry point. Otherwise useful blocks may be garbage collected.--* Note that updateFact must set the change-flag if a label goes from-  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the-  real fact lattice is-       UNR-       bottom-       the points above bottom--* Even if the fact is going from UNR to bottom, we still call the-  client's fact_join function because it might give the client-  some useful debugging information.--* All of this only applies for *forward* fixpoints.  For the backward-  case we must treat every block as reachable; it might finish with a-  'return', and therefore have no successors, for example.--}----------------------------------------------------------------------------------      DG: an internal data type for 'decorated graphs'---          TOTALLY internal to Hoopl; each block is decorated with a fact---------------------------------------------------------------------------------- @ start dg.tex-type Graph = Graph' Block-type DG f  = Graph' (DBlock f)-data DBlock f n e x = DBlock f (Block n e x) -- ^ block decorated with fact--- @ end dg.tex-instance NonLocal n => NonLocal (DBlock f n) where-  entryLabel (DBlock _ b) = entryLabel b-  successors (DBlock _ b) = successors b----- constructors--dgnil  :: DG f n O O-dgnilC :: DG f n C C-dgSplice  :: NonLocal n => DG f n e a -> DG f n a x -> DG f n e x------ observers--type GraphWithFacts n f e x = (Graph n e x, FactBase f)-  -- A Graph together with the facts for that graph-  -- The domains of the two maps should be identical--normalizeGraph :: forall n f e x .-                  NonLocal n => DG f n e x -> GraphWithFacts n f e x--normalizeGraph g = (graphMapBlocks dropFact g, facts g)-    where dropFact (DBlock _ b) = b-          facts :: DG f n e x -> FactBase f-          facts GNil = noFacts-          facts (GUnit _) = noFacts-          facts (GMany _ body exit) = bodyFacts body `mapUnion` exitFacts exit-          exitFacts :: MaybeO x (DBlock f n C O) -> FactBase f-          exitFacts NothingO = noFacts-          exitFacts (JustO (DBlock f b)) = mapSingleton (entryLabel b) f-          bodyFacts :: LabelMap (DBlock f n C C) -> FactBase f-          bodyFacts body = mapFold f noFacts body-            where f (DBlock f b) fb = mapInsert (entryLabel b) f fb----- implementation of the constructors (boring)--dgnil  = GNil-dgnilC = GMany NothingO emptyBody NothingO--dgSplice = U.splice fzCat-  where fzCat (DBlock f b1) (DBlock _ b2) = DBlock f (b1 `U.cat` b2)---------------------------------------------------------------------       Utilities--------------------------------------------------------------------- Lifting based on shape:---  - from nodes to blocks---  - from facts to fact-like things--- Lowering back:---  - from fact-like things to facts--- Note that the latter two functions depend only on the entry shape.--- @ start node.tex-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- fwdEntryLabel :: NonLocal n => n e x -> MaybeC e [Label]- ftransfer :: FwdPass m n f -> n e x -> f -> Fact x f- frewrite  :: FwdPass m n f -> n e x -           -> f -> m (Maybe (Graph n e x, FwdRewrite m n f))--- @ end node.tex- bwdEntryFact :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f- btransfer    :: BwdPass m n f -> n e x -> Fact x f -> f- brewrite     :: BwdPass m n f -> n e x-              -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f))--instance ShapeLifter C O where-  singletonDG f = gUnitCO . DBlock f . BFirst-  fwdEntryFact     n f  = mapSingleton (entryLabel n) f-  bwdEntryFact lat n fb = getFact lat (entryLabel n) fb-  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (ft, _, _)}) n f = ft n f-  btransfer (BwdPass {bp_transfer = BwdTransfer3 (bt, _, _)}) n f = bt n f-  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (fr, _, _)}) n f = fr n f-  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (br, _, _)}) n f = br n f-  fwdEntryLabel n = JustC [entryLabel n]--instance ShapeLifter O O where-  singletonDG f = gUnitOO . DBlock f . BMiddle-  fwdEntryFact   _ f = f-  bwdEntryFact _ _ f = f-  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, ft, _)}) n f = ft n f-  btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, bt, _)}) n f = bt n f-  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (_, fr, _)}) n f = fr n f-  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (_, br, _)}) n f = br n f-  fwdEntryLabel _ = NothingC--instance ShapeLifter O C where-  singletonDG f = gUnitOC . DBlock f . BLast-  fwdEntryFact   _ f = f-  bwdEntryFact _ _ f = f-  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, _, ft)}) n f = ft n f-  btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, _, bt)}) n f = bt n f-  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (_, _, fr)}) n f = fr n f-  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (_, _, br)}) n f = br n f-  fwdEntryLabel _ = NothingC---- Fact lookup: the fact `orelse` bottom-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.

@@ -1,103 +0,0 @@-{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-}--module Compiler.Hoopl.Debug -  ( TraceFn , debugFwdJoins , debugBwdJoins-  , debugFwdTransfers , debugBwdTransfers-  )-where--import Compiler.Hoopl.Dataflow-import Compiler.Hoopl.Show------------------------------------------------------------------------------------- | Debugging combinators:--- Each combinator takes a dataflow pass and produces--- a dataflow pass that can output debugging messages.--- You provide the function, we call it with the applicable message.--- --- The most common use case is probably to:------   1. import 'Debug.Trace'------   2. pass 'trace' as the 1st argument to the debug combinator------   3. pass 'const true' as the 2nd argument to the debug combinator------ There are two kinds of debugging messages for a join,--- depending on whether the join is higher in the lattice than the old fact:---   1. If the join is higher, we show:---         + Join@L: f1 `join` f2 = f'---      where:---        + indicates a change---        L is the label where the join takes place---        f1 is the old fact at the label---        f2 is the new fact we are joining to f1---        f' is the result of the join---   2. _ Join@L: f2 <= f1---      where:---        _ indicates no change---        L is the label where the join takes place---        f1 is the old fact at the label (which remains unchanged)---        f2 is the new fact we joined with f1------------------------------------------------------------------------------------debugFwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> FwdPass m n f -> FwdPass m n f-debugBwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> BwdPass m n f -> BwdPass m n f--type TraceFn    = forall a . String -> a -> a-type ChangePred = ChangeFlag -> Bool--debugFwdJoins trace pred p = p { fp_lattice = debugJoins trace pred $ fp_lattice p }-debugBwdJoins trace pred p = p { bp_lattice = debugJoins trace pred $ bp_lattice p }--debugJoins :: Show f => TraceFn -> ChangePred -> DataflowLattice f -> DataflowLattice f-debugJoins trace showPred l@(DataflowLattice {fact_join = join}) = l {fact_join = join'}-  where-   join' l f1@(OldFact of1) f2@(NewFact nf2) =-     if showPred c then trace output res else res-       where res@(c, f') = join l f1 f2-             output = case c of-                        SomeChange -> "+ Join@" ++ show l ++ ": " ++ show of1 ++ " `join` "-                                                                  ++ show nf2 ++ " = " ++ show f'-                        NoChange   -> "_ Join@" ++ show l ++ ": " ++ show nf2 ++ " <= " ++ show of1------------------------------------------------------------------------------------- Functions we'd like to have, but don't know how to implement generically:-----------------------------------------------------------------------------------type ShowN n   = forall e x . n e x ->      String-type FPred n f = forall e x . n e x -> f        -> Bool-type BPred n f = forall e x . n e x -> Fact x f -> Bool-debugFwdTransfers::-  forall m n f . Show f => TraceFn -> ShowN n -> FPred n f -> FwdPass m n f -> FwdPass m n f-debugFwdTransfers trace showN showPred pass = pass { fp_transfer = transfers' }-  where-    (f, m, l) = getFTransfer3 $ fp_transfer pass-    transfers' = mkFTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l)-    wrap :: forall e x . (Fact x f -> String) -> (n e x -> f -> Fact x f) -> n e x -> f -> Fact x f-    wrap showOutF ft n f = if showPred n f then trace output res else res-      where-        res    = ft n f-        output = name ++ " transfer: " ++ show f ++ " -> " ++ showN n ++ " -> " ++ showOutF res-    name = fact_name (fp_lattice pass)-    -debugBwdTransfers::-  forall m n f . Show f => TraceFn -> ShowN n -> BPred n f -> BwdPass m n f -> BwdPass m n f-debugBwdTransfers trace showN showPred pass = pass { bp_transfer = transfers' }-  where-    (f, m, l) = getBTransfer3 $ bp_transfer pass-    transfers' = mkBTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l)-    wrap :: forall e x . (Fact x f -> String) -> (n e x -> Fact x f -> f) -> n e x -> Fact x f -> f-    wrap showInF ft n f = if showPred n f then trace output res else res-      where-        res    = ft n f-        output = name ++ " transfer: " ++ showInF f ++ " -> " ++ showN n ++ " -> " ++ show res-    name = fact_name (bp_lattice pass)-    ---- debugFwdTransfers, debugFwdRewrites, debugFwdAll ::---   forall m n f . Show f => TraceFn -> ShowN n -> FwdPass m n f -> FwdPass m n f--- debugBwdTransfers, debugBwdRewrites, debugBwdAll ::---   forall m n f . Show f => TraceFn -> ShowN n -> BwdPass m n f -> BwdPass m n f-

@@ -1,105 +0,0 @@-{-# LANGUAGE TypeFamilies #-}----------------------------------------------------------------------------------		The fuel monad--------------------------------------------------------------------------------module Compiler.Hoopl.Fuel-  ( Fuel, infiniteFuel, fuelRemaining-  , withFuel-  , FuelMonad(..)-  , FuelMonadT(..)-  , CheckingFuelMonad-  , InfiniteFuelMonad-  , SimpleFuelMonad-  )-where--import Compiler.Hoopl.Checkpoint-import Compiler.Hoopl.Unique--class Monad m => FuelMonad m where-  getFuel :: m Fuel-  setFuel :: Fuel -> m ()---- | 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--class FuelMonadT fm where-  runWithFuel :: (Monad m, FuelMonad (fm m)) => Fuel -> fm m a -> m a---type Fuel = Int--withFuel :: FuelMonad m => Maybe a -> m (Maybe a)-withFuel Nothing  = return Nothing-withFuel (Just a) = do f <- getFuel-                       if f == 0-                         then return Nothing-                         else setFuel (f-1) >> return (Just a)---------------------------------------------------------------------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' })--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) })--instance Monad m => FuelMonad (CheckingFuelMonad m) where-  getFuel   = FM (\f -> return (f, f))-  setFuel f = FM (\_ -> return ((),f))--instance FuelMonadT CheckingFuelMonad where-  runWithFuel fuel m = do { (a, _) <- unFM m fuel; return a }--------------------------------------------------------------------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 UniqueMonad m => UniqueMonad (InfiniteFuelMonad m) where-  freshUnique = IFM $ freshUnique--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--infiniteFuel :: Fuel -- effectively infinite, any, but subtractable-infiniteFuel = maxBound--type SimpleFuelMonad = CheckingFuelMonad SimpleUniqueMonad--{--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,24 +0,0 @@-{-# LANGUAGE GADTs, RankNTypes #-}--{- Exposing some internals to GHC -}-module Compiler.Hoopl.GHC-  ( uniqueToInt-  , uniqueToLbl, lblToUnique-  , getFuel, setFuel-  , bodyToBlockMap, bodyOfBlockMap-  )-where--import Compiler.Hoopl.Fuel-import Compiler.Hoopl.Graph-import Compiler.Hoopl.Label-import Compiler.Hoopl.Unique---- Converts Body to a map of closed/closed blocks.--- It should better be a constant-time operation--- as GHC is counting on it.-bodyToBlockMap :: Body' block n -> LabelMap (block n C C)-bodyToBlockMap (Body bodyMap) = bodyMap--bodyOfBlockMap :: LabelMap (block n C C) -> Body' block n-bodyOfBlockMap = Body

@@ -1,119 +0,0 @@-{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies #-}--module Compiler.Hoopl.Graph -  ( O, C, Block(..), Body, Body'(..), Graph, Graph'(..)-  , MaybeO(..), MaybeC(..), Shape(..), IndexedCO-  , NonLocal(entryLabel, successors)-  , emptyBody, addBlock, bodyList-  )-where--import Compiler.Hoopl.Collections-import Compiler.Hoopl.Label----------------------------------------------------------------------------------		Graphs---------------------------------------------------------------------------------- | Used at the type level to indicate an "open" structure with    --- a unique, unnamed control-flow edge flowing in or out.         --- "Fallthrough" and concatenation are permitted at an open point.-data O -       -       --- | Used at the type level to indicate a "closed" structure which--- supports control transfer only through the use of named--- labels---no "fallthrough" is permitted.  The number of control-flow--- edges is unconstrained.-data C---- | A sequence of nodes.  May be any of four shapes (O/O, O/C, C/O, C/C).--- Open at the entry means single entry, mutatis mutandis for exit.--- A closed/closed block is a /basic/ block and can't be extended further.--- Clients should avoid manipulating blocks and should stick to either nodes--- or graphs.-data Block n e x where-  -- nodes-  BFirst  :: n C O                 -> Block n C O -- x^ block holds a single first node-  BMiddle :: n O O                 -> Block n O O -- x^ block holds a single middle node-  BLast   :: n O C                 -> Block n O C -- x^ block holds a single last node--  -- concatenation operations-  BCat    :: Block n O O -> Block n O O -> Block n O O -- non-list-like-  BHead   :: Block n C O -> n O O       -> Block n C O-  BTail   :: n O O       -> Block n O C -> Block n O C  --  BClosed :: Block n C O -> Block n O C -> Block n C C -- the zipper---- | A (possibly empty) collection of closed/closed blocks-type Body n = LabelMap (Block n C C)-newtype Body' block n = Body (LabelMap (block n C C))---- | A control-flow graph, which may take any of four shapes (O/O, O/C, C/O, C/C).--- A graph open at the entry has a single, distinguished, anonymous entry point;--- if a graph is closed at the entry, its entry point(s) are supplied by a context.-type Graph = Graph' Block-data Graph' block n e x where-  GNil  :: Graph' block n O O-  GUnit :: block n O O -> Graph' block n O O-  GMany :: MaybeO e (block n O C) -        -> LabelMap (block n C C)-        -> MaybeO x (block n C O)-        -> Graph' block n e x---- | Maybe type indexed by open/closed-data MaybeO ex t where-  JustO    :: t -> MaybeO O t-  NothingO ::      MaybeO C t---- | Maybe type indexed by closed/open-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 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-  fmap f (JustO a) = JustO (f a)--instance Functor (MaybeC ex) where-  fmap _ NothingC = NothingC-  fmap f (JustC a) = JustC (f a)------------------------------------ | Gives access to the anchor points for--- nonlocal edges as well as the edges themselves-class NonLocal thing where -  entryLabel :: thing C x -> Label   -- ^ The label of a first node or block-  successors :: thing e C -> [Label] -- ^ Gives control-flow successors--instance NonLocal n => NonLocal (Block n) where-  entryLabel (BFirst n)    = entryLabel n-  entryLabel (BHead h _)   = entryLabel h-  entryLabel (BClosed h _) = entryLabel h-  successors (BLast n)     = successors n-  successors (BTail _ t)   = successors t-  successors (BClosed _ t) = successors t---------------------------------emptyBody :: LabelMap (thing C C)-emptyBody = mapEmpty--addBlock :: NonLocal thing => thing C C -> LabelMap (thing C C) -> LabelMap (thing C C)-addBlock b body = nodupsInsert (entryLabel b) b body-  where nodupsInsert l b body = if mapMember l body then-                                    error $ "duplicate label " ++ show l ++ " in graph"-                                else-                                    mapInsert l b body--bodyList :: NonLocal (block n) => Body' block n -> [(Label,block n C C)]-bodyList (Body body) = mapToList body

@@ -1,124 +0,0 @@-{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}---- N.B. addBasicBlocks won't work on OO without a Node (branch/label) constraint--module Compiler.Hoopl.GraphUtil-  ( splice, gSplice , cat , bodyGraph, bodyUnion-  , frontBiasBlock, backBiasBlock-  )--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--splice :: forall block n e a x . NonLocal (block n) =>-          (forall e x . block n e O -> block n O x -> block n e x)-       -> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x)-splice bcat = sp-  where sp :: forall e a x .-              Graph' block n e a -> Graph' block n a x -> Graph' block n e x--        sp GNil g2 = g2-        sp g1 GNil = g1--        sp (GUnit b1) (GUnit b2) = GUnit (b1 `bcat` b2)--        sp (GUnit b) (GMany (JustO e) bs x) = GMany (JustO (b `bcat` e)) bs x--        sp (GMany e bs (JustO x)) (GUnit b2) = GMany e bs (JustO (x `bcat` b2))--        sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2)-          = GMany e1 (b1 `bodyUnion` b2) x2-          where b1 = addBlock (x1 `bcat` e2) bs1--        sp (GMany e1 b1 NothingO) (GMany NothingO b2 x2)-          = GMany e1 (b1 `bodyUnion` b2) x2--        sp _ _ = error "bogus GADT match failure"--bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a-bodyUnion = mapUnionWithKey nodups-  where nodups l _ _ = error $ "duplicate blocks with label " ++ show l--gSplice :: NonLocal n => Graph n e a -> Graph n a x -> Graph n e x-gSplice = splice cat--cat :: Block n e O -> Block n O x -> Block n e x-cat b1@(BFirst {})     (BMiddle n)  = BHead   b1 n-cat b1@(BFirst {})  b2@(BLast{})    = BClosed b1 b2-cat b1@(BFirst {})  b2@(BTail{})    = BClosed b1 b2-cat b1@(BFirst {})     (BCat b2 b3) = (b1 `cat` b2) `cat` b3-cat b1@(BHead {})      (BCat b2 b3) = (b1 `cat` b2) `cat` b3-cat b1@(BHead {})      (BMiddle n)  = BHead   b1 n-cat b1@(BHead {})   b2@(BLast{})    = BClosed b1 b2-cat b1@(BHead {})   b2@(BTail{})    = BClosed b1 b2-cat b1@(BMiddle {}) b2@(BMiddle{})  = BCat    b1 b2-cat    (BMiddle n)  b2@(BLast{})    = BTail    n b2-cat b1@(BMiddle {}) b2@(BCat{})     = BCat    b1 b2-cat    (BMiddle n)  b2@(BTail{})    = BTail    n b2-cat    (BCat b1 b2) b3@(BLast{})    = b1 `cat` (b2 `cat` b3)-cat    (BCat b1 b2) b3@(BTail{})    = b1 `cat` (b2 `cat` b3)-cat b1@(BCat {})    b2@(BCat{})     = BCat    b1 b2-cat b1@(BCat {})    b2@(BMiddle{})  = BCat    b1 b2----------------------------------------------------------------------- | A block is "front biased" if the left child of every--- concatenation operation is a node, not a general block; a--- front-biased block is analogous to an ordinary list.  If a block is--- front-biased, then its nodes can be traversed from front to back--- without general recusion; tail recursion suffices.  Not all shapes--- can be front-biased; a closed/open block is inherently back-biased.--frontBiasBlock :: Block n e x -> Block n e x-frontBiasBlock b@(BFirst  {}) = b-frontBiasBlock b@(BMiddle {}) = b-frontBiasBlock b@(BLast   {}) = b-frontBiasBlock b@(BCat {}) = rotate b-  where -- rotate and append ensure every left child of ZCat is ZMiddle-        -- provided 2nd argument to append already has this property-    rotate :: Block n O O -> Block n O O-    append :: Block n O O -> Block n O O -> Block n O O-    rotate (BCat h t)     = append h (rotate t)-    rotate b@(BMiddle {}) = b-    append b@(BMiddle {}) t = b `BCat` t-    append (BCat b1 b2) b3 = b1 `append` (b2 `append` b3)-frontBiasBlock b@(BHead {})    = b -- back-biased by nature; cannot fix-frontBiasBlock b@(BTail {})    = b -- statically front-biased-frontBiasBlock   (BClosed h t) = shiftRight h t-    where shiftRight :: Block n C O -> Block n O C -> Block n C C-          shiftRight (BHead b1 b2)  b3 = shiftRight b1 (BTail b2 b3)-          shiftRight b1@(BFirst {}) b2 = BClosed b1 b2---- | A block is "back biased" if the right child of every--- concatenation operation is a node, not a general block; a--- back-biased block is analogous to a snoc-list.  If a block is--- back-biased, then its nodes can be traversed from back to back--- without general recusion; tail recursion suffices.  Not all shapes--- can be back-biased; an open/closed block is inherently front-biased.--backBiasBlock :: Block n e x -> Block n e x-backBiasBlock b@(BFirst  {}) = b-backBiasBlock b@(BMiddle {}) = b-backBiasBlock b@(BLast   {}) = b-backBiasBlock b@(BCat {}) = rotate b-  where -- rotate and append ensure every right child of Cat is Middle-        -- provided 1st argument to append already has this property-    rotate :: Block n O O -> Block n O O-    append :: Block n O O -> Block n O O -> Block n O O-    rotate (BCat h t)     = append (rotate h) t-    rotate b@(BMiddle {}) = b-    append h b@(BMiddle {}) = h `BCat` b-    append b1 (BCat b2 b3) = (b1 `append` b2) `append` b3-backBiasBlock b@(BHead {}) = b -- statically back-biased-backBiasBlock b@(BTail {}) = b -- front-biased by nature; cannot fix-backBiasBlock (BClosed h t) = shiftLeft h t-    where shiftLeft :: Block n C O -> Block n O C -> Block n C C-          shiftLeft b1 (BTail b2 b3) = shiftLeft (BHead b1 b2) b3-          shiftLeft b1 b2@(BLast {}) = BClosed b1 b2

@@ -1,104 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module Compiler.Hoopl.Label-  ( Label-  , freshLabel-  , LabelSet, LabelMap-  , FactBase, noFacts, lookupFact--  , uniqueToLbl -- MkGraph and GHC use only-  , lblToUnique -- GHC use only-  )--where--import Compiler.Hoopl.Collections-import Compiler.Hoopl.Unique----------------------------------------------------------------------------------		Label--------------------------------------------------------------------------------newtype Label = Label { lblToUnique :: Unique }-  deriving (Eq, Ord)--uniqueToLbl :: Unique -> Label-uniqueToLbl = Label--instance Show Label where-  show (Label n) = "L" ++ show n--freshLabel :: UniqueMonad m => m Label-freshLabel = freshUnique >>= return . uniqueToLbl---------------------------------------------------------------------------------- LabelSet--newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show)--instance IsSet LabelSet where-  type ElemOf LabelSet = Label--  setNull (LS s) = setNull s-  setSize (LS s) = setSize s-  setMember (Label k) (LS s) = setMember k s--  setEmpty = LS setEmpty-  setSingleton (Label k) = LS (setSingleton k)-  setInsert (Label k) (LS s) = LS (setInsert k s)-  setDelete (Label k) (LS s) = LS (setDelete k s)--  setUnion (LS x) (LS y) = LS (setUnion x y)-  setDifference (LS x) (LS y) = LS (setDifference x y)-  setIntersection (LS x) (LS y) = LS (setIntersection x y)-  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y--  setFold k z (LS s) = setFold (k . uniqueToLbl) z s--  setElems (LS s) = map uniqueToLbl (setElems s)-  setFromList ks = LS (setFromList (map lblToUnique ks))---------------------------------------------------------------------------------- LabelMap--newtype LabelMap v = LM (UniqueMap v) deriving (Eq, Ord, Show)--instance IsMap LabelMap where-  type KeyOf LabelMap = Label--  mapNull (LM m) = mapNull m-  mapSize (LM m) = mapSize m-  mapMember (Label k) (LM m) = mapMember k m-  mapLookup (Label k) (LM m) = mapLookup k m-  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m--  mapEmpty = LM mapEmpty-  mapSingleton (Label k) v = LM (mapSingleton k v)-  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)-  mapDelete (Label k) (LM m) = LM (mapDelete k m)--  mapUnion (LM x) (LM y) = LM (mapUnion x y)-  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y)-  mapDifference (LM x) (LM y) = LM (mapDifference x y)-  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)-  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y--  mapMap f (LM m) = LM (mapMap f m)-  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m)-  mapFold k z (LM m) = mapFold k z m-  mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m--  mapElems (LM m) = mapElems m-  mapKeys (LM m) = map uniqueToLbl (mapKeys m)-  mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m]-  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])---------------------------------------------------------------------------------- FactBase--type FactBase f = LabelMap f--noFacts :: FactBase f-noFacts = mapEmpty--lookupFact :: Label -> FactBase f -> Maybe f-lookupFact = mapLookup

@@ -1,252 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, GADTs, TypeSynonymInstances, FlexibleInstances, RankNTypes #-}-module Compiler.Hoopl.MkGraph-    ( AGraph, graphOfAGraph, aGraphOfGraph-    , (<*>), (|*><*|), catGraphs, addEntrySeq, addExitSeq, addBlocks, unionBlocks-    , emptyGraph, emptyClosedGraph, withFresh-    , mkFirst, mkMiddle, mkMiddles, mkLast, mkBranch, mkLabel, mkWhileDo-    , IfThenElseable(mkIfThenElse)-    , mkEntry, mkExit-    , HooplNode(mkLabelNode, mkBranchNode)-    )-where--import Compiler.Hoopl.Label (Label, uniqueToLbl)-import Compiler.Hoopl.Graph-import qualified Compiler.Hoopl.GraphUtil as U-import Compiler.Hoopl.Unique-import Control.Monad (liftM2)--{-|-As noted in the paper, we can define a single, polymorphic type of -splicing operation with the very polymorphic type-@-  AGraph n e a -> AGraph n a x -> AGraph n e x-@-However, we feel that this operation is a bit /too/ polymorphic,-and that it's too easy for clients to use it blindly without -thinking.  We therfore split it into two operations, '<*>' and '|*><*|', -which are supplemented by other functions:--  * The '<*>' operator is true concatenation, for connecting open graphs.-    Control flows from the left graph to the right graph.--  * The '|*><*|' operator splices together two graphs at a closed-    point. Nothing is known about control flow. The vertical bar-    stands for "closed point" just as the angle brackets above stand-    for "open point".  Unlike the <*> operator, the |*><*| can create-    a control-flow graph with dangling outedges or unreachable blocks.-    The operator must be used carefully, so we have chosen a long name-    on purpose, to help call people's attention to what they're doing.--  * The operator 'addBlocks' adds a set of basic blocks (represented-    as a closed/closed 'AGraph' to an existing graph, without changing-    the shape of the existing graph.  In some cases, it's necessary to-    introduce a branch and a label to 'get around' the blocks added,-    so this operator, and other functions based on it, requires a-    'HooplNode' type-class constraint and is available only on AGraph,-    not Graph.--  * We have discussed a dynamic assertion about dangling outedges and-    unreachable blocks, but nothing is implemented yet.---}----class GraphRep g where-  -- | An empty graph that is open at entry and exit.  -  -- It is the left and right identity of '<*>'.-  emptyGraph       :: g n O O-  -- | An empty graph that is closed at entry and exit.  -  -- It is the left and right identity of '|*><*|'.-  emptyClosedGraph :: g n C C-  -- | Create a graph from a first node-  mkFirst  :: n C O -> g n C O-  -- | Create a graph from a middle node-  mkMiddle :: n O O -> g n O O-  -- | Create a graph from a last node-  mkLast   :: n O C -> g n O C-  mkFirst = mkExit  . BFirst-  mkLast  = mkEntry . BLast-  infixl 3 <*>-  infixl 2 |*><*| -  -- | Concatenate two graphs; control flows from left to right.-  (<*>)    :: NonLocal n => g n e O -> g n O x -> g n e x-  -- | Splice together two graphs at a closed point; nothing is known-  -- about control flow.-  (|*><*|) :: NonLocal n => g n e C -> g n C x -> g n e x-  -- | Conveniently concatenate a sequence of open/open graphs using '<*>'.-  catGraphs :: NonLocal n => [g n O O] -> g n O O-  catGraphs = foldr (<*>) emptyGraph--  -- | Create a graph that defines a label-  mkLabel  :: HooplNode n => Label -> g n C O -- definition of the label-  -- | Create a graph that branches to a label-  mkBranch :: HooplNode n => Label -> g n O C -- unconditional branch to the label--  -- | Conveniently concatenate a sequence of middle nodes to form-  -- an open/open graph.-  mkMiddles :: NonLocal n => [n O O] -> g n O O--  mkLabel  id     = mkFirst $ mkLabelNode id-  mkBranch target = mkLast  $ mkBranchNode target-  mkMiddles ms    = catGraphs $ map mkMiddle ms--  -- | Create a graph containing only an entry sequence-  mkEntry   :: Block n O C -> g n O C-  -- | Create a graph containing only an exit sequence-  mkExit    :: Block n C O -> g n C O--instance GraphRep Graph where-  emptyGraph  = GNil-  emptyClosedGraph = GMany NothingO emptyBody NothingO-  (<*>)       = U.gSplice-  (|*><*|)    = U.gSplice-  mkMiddle    = GUnit . BMiddle-  mkExit   block = GMany NothingO      emptyBody (JustO block)-  mkEntry  block = GMany (JustO block) emptyBody NothingO--instance GraphRep AGraph where-  emptyGraph  = aGraphOfGraph emptyGraph-  emptyClosedGraph = aGraphOfGraph emptyClosedGraph-  (<*>)       = liftA2 (<*>)-  (|*><*|)    = liftA2 (|*><*|)-  mkMiddle    = aGraphOfGraph . mkMiddle-  mkExit  = aGraphOfGraph . mkExit-  mkEntry = aGraphOfGraph . mkEntry----- | The type of abstract graphs.  Offers extra "smart constructors"--- that may consume fresh labels during construction.-newtype AGraph n e x =-  A { graphOfAGraph :: forall m. UniqueMonad m =>-                       m (Graph n e x) -- ^ Take an abstract 'AGraph'-                                       -- and make a concrete (if monadic)-                                       -- 'Graph'.-    }---- | Take a graph and make it abstract.-aGraphOfGraph :: Graph n e x -> AGraph n e x-aGraphOfGraph g = A (return g)----- | The 'Labels' class defines things that can be lambda-bound--- by an argument to 'withFreshLabels'.  Such an argument may--- lambda-bind a single 'Label', or if multiple labels are needed,--- it can bind a tuple.  Tuples can be nested, so arbitrarily many--- fresh labels can be acquired in a single call.--- --- For example usage see implementations of 'mkIfThenElse' and 'mkWhileDo'.-class Uniques u where-  withFresh :: (u -> AGraph n e x) -> AGraph n e x--instance Uniques Unique where-  withFresh f = A $ freshUnique >>= (graphOfAGraph . f)--instance Uniques Label where-  withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl)---- | 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 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 (A g) (A blocks) = A $ g >>= \g -> blocks >>= add g-  where add :: (UniqueMonad 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 `U.bodyUnion` body') x-        add g@GNil      blocks = spliceOO g blocks-        add g@(GUnit _) blocks = spliceOO g blocks-        spliceOO :: (HooplNode n, UniqueMonad m)-                 => Graph n O O -> Graph n C C -> m (Graph n O O)-        spliceOO g blocks = graphOfAGraph $ withFresh $ \l ->-          A (return g) <*> mkBranch l |*><*| A (return blocks) |*><*| mkLabel l---- | For some graph-construction operations and some optimizations,--- Hoopl must be able to create control-flow edges using a given node--- type 'n'.-class NonLocal n => HooplNode n where-  -- | Create a branch node, the source of a control-flow edge.-  mkBranchNode :: Label -> n O C-  -- | Create a label node, the target (destination) of a control-flow edge.-  mkLabelNode  :: Label -> n C O-------------------------------------------------------------------                   Shiny Things-----------------------------------------------------------------class IfThenElseable x where-  -- | Translate a high-level if-then-else construct into an 'AGraph'.-  -- 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--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--instance IfThenElseable O where-  mkIfThenElse cbranch tbranch fbranch = withFresh $ \(endif, ltrue, lfalse) ->-    cbranch ltrue lfalse |*><*|-      mkLabel ltrue  <*> tbranch <*> mkBranch endif |*><*|-      mkLabel lfalse <*> fbranch <*> mkBranch endif |*><*|-      mkLabel endif--instance IfThenElseable C where-  mkIfThenElse cbranch tbranch fbranch = withFresh $ \(ltrue, lfalse) ->-    cbranch ltrue lfalse |*><*|-       mkLabel ltrue  <*> tbranch |*><*|-       mkLabel lfalse <*> fbranch--mkWhileDo cbranch body = withFresh $ \(test, head, endwhile) ->-     -- Forrest Baskett's while-loop layout-  mkBranch test |*><*|-    mkLabel head <*> body <*> mkBranch test |*><*|-    mkLabel test <*> cbranch head endwhile  |*><*|-    mkLabel endwhile-------------------------------------------------------------------               Boring instance declarations------------------------------------------------------------------instance (Uniques u1, Uniques u2) => Uniques (u1, u2) where-  withFresh f = withFresh $ \u1 ->-                withFresh $ \u2 ->-                f (u1, u2)--instance (Uniques u1, Uniques u2, Uniques u3) => Uniques (u1, u2, u3) where-  withFresh f = withFresh $ \u1 ->-                withFresh $ \u2 ->-                withFresh $ \u3 ->-                f (u1, u2, u3)--instance (Uniques u1, Uniques u2, Uniques u3, Uniques u4) => Uniques (u1, u2, u3, u4) where-  withFresh f = withFresh $ \u1 ->-                withFresh $ \u2 ->-                withFresh $ \u3 ->-                withFresh $ \u4 ->-                f (u1, u2, u3, u4)-------------------------------------------------- deprecated legacy functions--{-# DEPRECATED addEntrySeq, addExitSeq, unionBlocks "use |*><*| instead" #-}-addEntrySeq :: NonLocal n => AGraph n O C -> AGraph n C x -> AGraph n O x-addExitSeq  :: NonLocal n => AGraph n e C -> AGraph n C O -> AGraph n e O-unionBlocks :: NonLocal n => AGraph n C C -> AGraph n C C -> AGraph n C C--addEntrySeq = (|*><*|)-addExitSeq  = (|*><*|)-unionBlocks = (|*><*|)

@@ -1,45 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}--module Compiler.Hoopl.Passes.DList-  ( Doms, domEntry, domLattice-  , domPass-  )-where--import Compiler.Hoopl---type Doms = WithBot [Label]--- ^ List of labels, extended with a standard bottom element---- | The fact that goes into the entry of a dominator analysis: the first node--- is dominated only by the entry point, which is represented by the empty list--- of labels.-domEntry :: Doms-domEntry = PElem []--domLattice :: DataflowLattice Doms-domLattice = addPoints "dominators" extend--extend :: JoinFun [Label]-extend _ (OldFact l) (NewFact l') = (changeIf (l `lengthDiffers` j), j)-    where j = lcs l l'-          lcs :: [Label] -> [Label] -> [Label] -- longest common suffix-          lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l'-                   | length l < length l' = lcs l' l-                   | otherwise = dropUnlike l l' l-          dropUnlike [] [] maybe_like = maybe_like-          dropUnlike (x:xs) (y:ys) maybe_like =-              dropUnlike xs ys (if x == y then maybe_like else xs)-          dropUnlike _ _ _ = error "this can't happen"--          lengthDiffers [] [] = False-          lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys-          lengthDiffers [] (_:_) = True-          lengthDiffers (_:_) [] = True---- | Dominator pass-domPass :: (NonLocal n, Monad m) => FwdPass m n Doms-domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite-  where first n = fmap (entryLabel n:)

@@ -1,130 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}--module Compiler.Hoopl.Passes.Dominator-  ( Doms, DPath(..), domPath, domEntry, domLattice, extendDom-  , DominatorNode(..), DominatorTree(..), tree-  , immediateDominators-  , domPass-  )-where--import Data.Maybe--import Compiler.Hoopl---type Doms = WithBot DPath--- ^ List of labels, extended with a standard bottom element---- | The fact that goes into the entry of a dominator analysis: the first node--- is dominated only by the entry point, which is represented by the empty list--- of labels.-domEntry :: Doms-domEntry = PElem (DPath [])--newtype DPath = DPath [Label]-  -- ^ represents part of the domination relation: each label-  -- in a list is dominated by all its successors.  This is a newtype only so-  -- we can give it a fancy Show instance.--instance Show DPath where-  show (DPath ls) = concat (foldr (\l path -> show l : " -> " : path) ["entry"] ls)--domPath :: Doms -> [Label]-domPath Bot = [] -- lies: an unreachable node appears to be dominated by the entry-domPath (PElem (DPath ls)) = ls--extendDom :: Label -> DPath -> DPath-extendDom l (DPath ls) = DPath (l:ls)--domLattice :: DataflowLattice Doms-domLattice = addPoints "dominators" extend--extend :: JoinFun DPath-extend _ (OldFact (DPath l)) (NewFact (DPath l')) =-                                (changeIf (l `lengthDiffers` j), DPath j)-    where j = lcs l l'-          lcs :: [Label] -> [Label] -> [Label] -- longest common suffix-          lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l'-                   | length l < length l' = lcs l' l-                   | otherwise = dropUnlike l l' l-          dropUnlike [] [] maybe_like = maybe_like-          dropUnlike (x:xs) (y:ys) maybe_like =-              dropUnlike xs ys (if x == y then maybe_like else xs)-          dropUnlike _ _ _ = error "this can't happen"--          lengthDiffers [] [] = False-          lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys-          lengthDiffers [] (_:_) = True-          lengthDiffers (_:_) [] = True------ | Dominator pass-domPass :: (NonLocal n, Monad m) => FwdPass m n Doms-domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite-  where first n = fmap (extendDom $ entryLabel n)--------------------------------------------------------------------data DominatorNode = Entry | Labelled Label-data DominatorTree = Dominates DominatorNode [DominatorTree]--- ^ This data structure is a *rose tree* in which each node may have---  arbitrarily many children.  Each node dominates all its descendants.---- | Map from a FactBase for dominator lists into a--- dominator tree.  -tree :: [(Label, Doms)] -> DominatorTree-tree facts = Dominates Entry $ merge $ map reverse $ map mkList facts-   -- This code has been lightly tested.  The key insight is this: to-   -- find lists that all have the same head, convert from a list of-   -- lists to a finite map, in 'children'.  Then, to convert from the-   -- finite map to list of dominator trees, use the invariant that-   -- each key dominates all the lists of values.-  where merge lists = mapTree $ children $ filter (not . null) lists-        children = foldl addList noFacts-        addList :: FactBase [[Label]] -> [Label] -> FactBase [[Label]]-        addList map (x:xs) = mapInsert 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) <- mapToList map]-        mkList (l, doms) = l : domPath doms---instance Show DominatorTree where-  show = tree2dot---- | Given a dominator tree, produce a string representation, in the--- input language of dot, that will enable dot to produce a--- visualization of the tree.  For more info about dot see--- http://www.graphviz.org.--tree2dot :: DominatorTree -> String-tree2dot t = concat $ "digraph {\n" : dot t ["}\n"]-  where-    dot :: DominatorTree -> [String] -> [String]-    dot (Dominates root trees) = -                   (dotnode root :) . outedges trees . flip (foldl subtree) trees-      where outedges [] = id-            outedges (Dominates n _ : ts) =-                \s -> "  " : show root : " -> " : show n : "\n" : outedges ts s-            dotnode Entry = "  entryNode [shape=plaintext, label=\"entry\"]\n"-            dotnode (Labelled l) = "  " ++ show l ++ "\n"-            subtree = flip dot--instance Show DominatorNode where-  show Entry = "entryNode"-  show (Labelled l) = show l---------------------------------------------------------------------- | Takes FactBase from dominator analysis and returns a map from each --- label to its immediate dominator, if any-immediateDominators :: FactBase Doms -> LabelMap Label-immediateDominators = mapFoldWithKey add mapEmpty-    where add l (PElem (DPath (idom:_))) = mapInsert l idom -          add _ _ = id-

@@ -1,147 +0,0 @@-{-# LANGUAGE GADTs, ScopedTypeVariables #-}---- | Possibly doubly pointed lattices--module Compiler.Hoopl.Pointed-  ( Pointed(..), addPoints, addPoints', addTop, addTop'-  , liftJoinTop, extendJoinDomain-  , WithTop, WithBot, WithTopAndBot-  )-where--import Compiler.Hoopl.Graph-import Compiler.Hoopl.Label-import Compiler.Hoopl.Dataflow---- | Adds top, bottom, or both to help form a lattice-data Pointed t b a where-   Bot   ::      Pointed t C a-   PElem :: a -> Pointed t b a-   Top   ::      Pointed C b a---- ^ The type parameters 't' and 'b' are used to say whether top--- and bottom elements have been added.  The analogy with 'Block'--- is nearly exact:------  * A 'Block' is closed at the entry if and only if it has a first node;---    a 'Pointed' is closed at the top if and only if it has a top element.------  * A 'Block' is closed at the exit if and only if it has a last node;---    a 'Pointed' is closed at the bottom if and only if it has a bottom element.------ We thus have four possible types, of which three are interesting:------  [@Pointed C C a@] Type @a@ extended with both top and bottom elements.------  [@Pointed C O a@] Type @a@ extended with a top element---  only. (Presumably @a@ comes equipped with a bottom element of its own.)------  [@Pointed O C a@] Type @a@ extended with a bottom element only. ------  [@Pointed O O a@] Isomorphic to @a@, and therefore not interesting.------ The advantage of all this GADT-ishness is that the constructors--- 'Bot', 'Top', and 'PElem' can all be used polymorphically.------ A 'Pointed t b' type is an instance of 'Functor' and 'Show'.----type WithBot a = Pointed O C a--- ^ Type 'a' with a bottom element adjoined--type WithTop a = Pointed C O a--- ^ Type 'a' with a top element adjoined--type WithTopAndBot a = Pointed C C a--- ^ Type 'a' with top and bottom elements adjoined----- | Given a join function and a name, creates a semi lattice by--- adding a bottom element, and possibly a top element also.--- A specialized version of 'addPoints''.-addPoints  :: String -> JoinFun a -> DataflowLattice (Pointed t C a)--- | A more general case for creating a new lattice-addPoints' :: forall a t .-              String-           -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, Pointed t C a))-           -> DataflowLattice (Pointed t C a)--addPoints name join = addPoints' name join'-   where join' l o n = (change, PElem f)-            where (change, f) = join l o n--addPoints' name joinx = DataflowLattice name Bot join-  where -- careful: order of cases matters for ChangeFlag-        join :: JoinFun (Pointed t C a)-        join _ (OldFact f)            (NewFact Bot) = (NoChange, f)-        join _ (OldFact Top)          (NewFact _)   = (NoChange, Top)-        join _ (OldFact Bot)          (NewFact f)   = (SomeChange, f)-        join _ (OldFact _)            (NewFact Top) = (SomeChange, Top)-        join l (OldFact (PElem old)) (NewFact (PElem new))-           = joinx l (OldFact old) (NewFact new)---liftJoinTop :: JoinFun a -> JoinFun (WithTop a)-extendJoinDomain :: forall a-              . (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a))-             -> JoinFun (WithTop a)--extendJoinDomain joinx = join- where join :: JoinFun (WithTop a)-       join _ (OldFact Top)          (NewFact _)   = (NoChange, Top)-       join _ (OldFact _)            (NewFact Top) = (SomeChange, Top)-       join l (OldFact (PElem old)) (NewFact (PElem new))-           = joinx l (OldFact old) (NewFact new)--liftJoinTop joinx = extendJoinDomain (\l old new -> liftPair $ joinx l old new)-  where liftPair (c, a) = (c, PElem a)---- | Given a join function and a name, creates a semi lattice by--- adding a top element but no bottom element.  Caller must supply the bottom --- element.-addTop  :: DataflowLattice a -> DataflowLattice (WithTop a)--- | A more general case for creating a new lattice-addTop' :: forall a .-              String-           -> a-           -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a))-           -> DataflowLattice (WithTop a)--addTop lattice = addTop' name' (fact_bot lattice) join'-   where name' = fact_name lattice ++ " + T"-         join' l o n = (change, PElem f)-            where (change, f) = fact_join lattice l o n--addTop' name bot joinx = DataflowLattice name (PElem bot) join-  where -- careful: order of cases matters for ChangeFlag-        join :: JoinFun (WithTop a)-        join _ (OldFact Top)          (NewFact _)   = (NoChange, Top)-        join _ (OldFact _)            (NewFact Top) = (SomeChange, Top)-        join l (OldFact (PElem old)) (NewFact (PElem new))-           = joinx l (OldFact old) (NewFact new)--instance Show a => Show (Pointed t b a) where-  show Bot = "_|_"-  show Top = "T"-  show (PElem a) = show a--instance Functor (Pointed t b) where-  fmap _ Bot = Bot-  fmap _ Top = Top-  fmap f (PElem a) = PElem (f a)--instance Eq a => Eq (Pointed t b a) where-  Bot == Bot = True-  Top == Top = True-  (PElem a) == (PElem a') = a == a'-  _ == _ = False--instance Ord a => Ord (Pointed t b a) where-  Bot     `compare` Bot      = EQ-  Bot     `compare` _        = LT-  _       `compare` Bot      = GT-  PElem a `compare` PElem a' = a `compare` a'-  Top     `compare` Top      = EQ-  Top     `compare` _        = GT-  _       `compare` Top      = LT

@@ -1,50 +0,0 @@-{-# LANGUAGE GADTs, EmptyDataDecls #-}--module Compiler.Hoopl.Shape {-# DEPRECATED "not ready to migrate to this yet" #-}-where---- | Used at the type level to indicate an "open" structure with    --- a unique, unnamed control-flow edge flowing in or out.         --- "Fallthrough" and concatenation are permitted at an open point.-data O -       -       --- | Used at the type level to indicate a "closed" structure which--- supports control transfer only through the use of named--- labels---no "fallthrough" is permitted.  The number of control-flow--- edges is unconstrained.-data C---data HalfShape s where-  ShapeO :: HalfShape O-  ShapeC :: HalfShape C--data Shape e x where-  ShapeOO :: Shape O O-  ShapeCO :: Shape C O-  ShapeOC :: Shape O C-  ShapeCC :: Shape C C--class Shapely n where-  shape        :: n e x -> Shape e x-  shapeAtEntry :: n e x -> HalfShape e-  shapeAtExit  :: n e x -> HalfShape x--  shapeAtEntry = entryHalfShape . shape-  shapeAtExit  = exitHalfShape  . shape-  --entryHalfShape :: Shape e x -> HalfShape e-exitHalfShape  :: Shape e x -> HalfShape x--entryHalfShape ShapeOO = ShapeO-entryHalfShape ShapeOC = ShapeO-entryHalfShape ShapeCO = ShapeC-entryHalfShape ShapeCC = ShapeC--exitHalfShape ShapeOO = ShapeO-exitHalfShape ShapeOC = ShapeC-exitHalfShape ShapeCO = ShapeO-exitHalfShape ShapeCC = ShapeC-

@@ -1,41 +0,0 @@-{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-}--module Compiler.Hoopl.Show -  ( showGraph, showFactBase-  )-where--import Compiler.Hoopl.Collections-import Compiler.Hoopl.Graph-import Compiler.Hoopl.Label------------------------------------------------------------------------------------- Prettyprinting-----------------------------------------------------------------------------------type Showing n = forall e x . n e x -> String- --showGraph :: forall n e x . (NonLocal n) => Showing n -> Graph n e x -> String-showGraph node = g-  where g :: (NonLocal n) => Graph n e x -> String-        g GNil = ""-        g (GUnit block) = b block-        g (GMany g_entry g_blocks g_exit) =-            open b g_entry ++ body g_blocks ++ open b g_exit-        body blocks = concatMap b (mapElems blocks)-        b :: forall e x . Block n e x -> String-        b (BFirst  n)     = node n-        b (BMiddle n)     = node n-        b (BLast   n)     = node n ++ "\n"-        b (BCat b1 b2)    = b b1   ++ b b2-        b (BHead b1 n)    = b b1   ++ node n ++ "\n"-        b (BTail n b1)    = node n ++ b b1-        b (BClosed b1 b2) = b b1   ++ b b2--open :: (a -> String) -> MaybeO z a -> String-open _ NothingO  = ""-open p (JustO n) = p n--showFactBase :: Show f => FactBase f -> String-showFactBase = show . mapToList

@@ -1,134 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module Compiler.Hoopl.Unique-  ( Unique, intToUnique-  , UniqueSet, UniqueMap-  , UniqueMonad(..)-  , SimpleUniqueMonad, runSimpleUniqueMonad-  , UniqueMonadT, runUniqueMonadT--  , uniqueToInt -- exposed through GHC module only!-  )--where--import Compiler.Hoopl.Checkpoint-import Compiler.Hoopl.Collections--import qualified Data.IntMap as M-import qualified Data.IntSet as S----------------------------------------------------------------------------------		Unique--------------------------------------------------------------------------------data Unique = Unique { uniqueToInt ::  {-# UNPACK #-} !Int }-  deriving (Eq, Ord)--intToUnique :: Int -> Unique-intToUnique = Unique--instance Show Unique where-  show (Unique n) = show n---------------------------------------------------------------------------------- UniqueSet--newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show)--instance IsSet UniqueSet where-  type ElemOf UniqueSet = Unique--  setNull (US s) = S.null s-  setSize (US s) = S.size s-  setMember (Unique k) (US s) = S.member k s--  setEmpty = US S.empty-  setSingleton (Unique k) = US (S.singleton k)-  setInsert (Unique k) (US s) = US (S.insert k s)-  setDelete (Unique k) (US s) = US (S.delete k s)--  setUnion (US x) (US y) = US (S.union x y)-  setDifference (US x) (US y) = US (S.difference x y)-  setIntersection (US x) (US y) = US (S.intersection x y)-  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y--  setFold k z (US s) = S.fold (k . intToUnique) z s--  setElems (US s) = map intToUnique (S.elems s)-  setFromList ks = US (S.fromList (map uniqueToInt ks))---------------------------------------------------------------------------------- UniqueMap--newtype UniqueMap v = UM (M.IntMap v) deriving (Eq, Ord, Show)--instance IsMap UniqueMap where-  type KeyOf UniqueMap = Unique--  mapNull (UM m) = M.null m-  mapSize (UM m) = M.size m-  mapMember (Unique k) (UM m) = M.member k m-  mapLookup (Unique k) (UM m) = M.lookup k m-  mapFindWithDefault def (Unique k) (UM m) = M.findWithDefault def k m--  mapEmpty = UM M.empty-  mapSingleton (Unique k) v = UM (M.singleton k v)-  mapInsert (Unique k) v (UM m) = UM (M.insert k v m)-  mapDelete (Unique k) (UM m) = UM (M.delete k m)--  mapUnion (UM x) (UM y) = UM (M.union x y)-  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey (f . intToUnique) x y)-  mapDifference (UM x) (UM y) = UM (M.difference x y)-  mapIntersection (UM x) (UM y) = UM (M.intersection x y)-  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y--  mapMap f (UM m) = UM (M.map f m)-  mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m)-  mapFold k z (UM m) = M.fold k z m-  mapFoldWithKey k z (UM m) = M.foldWithKey (k . intToUnique) z m--  mapElems (UM m) = M.elems m-  mapKeys (UM m) = map intToUnique (M.keys m)-  mapToList (UM m) = [(intToUnique k, v) | (k, v) <- M.toList m]-  mapFromList assocs = UM (M.fromList [(uniqueToInt k, v) | (k, v) <- assocs])--------------------------------------------------------------------- Monads--class Monad m => UniqueMonad m where-  freshUnique :: m Unique--newtype SimpleUniqueMonad a = SUM { unSUM :: [Unique] -> (a, [Unique]) }--instance Monad SimpleUniqueMonad where-  return a = SUM $ \us -> (a, us)-  m >>= k  = SUM $ \us -> let (a, us') = unSUM m us in-                              unSUM (k a) us'--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)--------------------------------------------------------------------newtype UniqueMonadT m a = UMT { unUMT :: [Unique] -> m (a, [Unique]) }--instance Monad m => Monad (UniqueMonadT m) where-  return a = UMT $ \us -> return (a, us)-  m >>= k  = UMT $ \us -> do { (a, us') <- unUMT m us; unUMT (k a) us' }--instance Monad m => UniqueMonad (UniqueMonadT m) where-  freshUnique = UMT $ \(u:us) -> return (u, us)--runUniqueMonadT :: Monad m => UniqueMonadT m a -> m a-runUniqueMonadT m = do { (a, _) <- unUMT m allUniques; return a }--allUniques :: [Unique]-allUniques = map Unique [1..]

@@ -1,263 +0,0 @@-{-# LANGUAGE GADTs, ScopedTypeVariables, FlexibleInstances, RankNTypes #-}--module Compiler.Hoopl.Util-  ( gUnitOO, gUnitOC, gUnitCO, gUnitCC-  , catGraphNodeOC, catGraphNodeOO-  , catNodeCOGraph, catNodeOOGraph-  , graphMapBlocks-  , blockMapNodes, blockMapNodes3-  , blockGraph-  , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except-  , preorder_dfs, preorder_dfs_from_except-  , labelsDefined, labelsUsed, externalEntryLabels-  , LabelsPtr(..)-  )-where--import Control.Monad--import Compiler.Hoopl.Collections-import Compiler.Hoopl.Graph-import Compiler.Hoopl.Label---------------------------------------------------------------------gUnitOO :: block n O O -> Graph' block n O O-gUnitOC :: block n O C -> Graph' block n O C-gUnitCO :: block n C O -> Graph' block n C O-gUnitCC :: NonLocal (block n) => block n C C -> Graph' block n C C-gUnitOO b = GUnit b-gUnitOC b = GMany (JustO b) emptyBody  NothingO-gUnitCO b = GMany NothingO  emptyBody (JustO b)-gUnitCC b = GMany NothingO  (addBlock b emptyBody) NothingO---catGraphNodeOO ::            Graph n e O -> n O O -> Graph n e O-catGraphNodeOC :: NonLocal n => Graph n e O -> n O C -> Graph n e C-catNodeOOGraph ::            n O O -> Graph n O x -> Graph n O x-catNodeCOGraph :: NonLocal n => n C O -> Graph n O x -> Graph n C x--catGraphNodeOO GNil                     n = gUnitOO $ BMiddle n-catGraphNodeOO (GUnit b)                n = gUnitOO $ b `BCat` BMiddle n-catGraphNodeOO (GMany e body (JustO x)) n = GMany e body (JustO $ x `BHead` n)--catGraphNodeOC GNil                     n = gUnitOC $ BLast n-catGraphNodeOC (GUnit b)                n = gUnitOC $ addToLeft b $ BLast n-  where addToLeft :: Block n O O -> Block n O C -> Block n O C-        addToLeft (BMiddle m)    g = m `BTail` g-        addToLeft (b1 `BCat` b2) g = addToLeft b1 $ addToLeft b2 g-catGraphNodeOC (GMany e body (JustO x)) n = GMany e body' NothingO-  where body' = addBlock (x `BClosed` BLast n) body--catNodeOOGraph n GNil                     = gUnitOO $ BMiddle n-catNodeOOGraph n (GUnit b)                = gUnitOO $ BMiddle n `BCat` b-catNodeOOGraph n (GMany (JustO e) body x) = GMany (JustO $ n `BTail` e) body x--catNodeCOGraph n GNil                     = gUnitCO $ BFirst n-catNodeCOGraph n (GUnit b)                = gUnitCO $ addToRight (BFirst n) b-  where addToRight :: Block n C O -> Block n O O -> Block n C O-        addToRight g (BMiddle m)    = g `BHead` m-        addToRight g (b1 `BCat` b2) = addToRight (addToRight g b1) b2-catNodeCOGraph n (GMany (JustO e) body x) = GMany NothingO body' x-  where body' = addBlock (BFirst n `BClosed` e) body------blockGraph :: NonLocal n => Block n e x -> Graph n e x-blockGraph b@(BFirst  {}) = gUnitCO b-blockGraph b@(BMiddle {}) = gUnitOO b-blockGraph b@(BLast   {}) = gUnitOC b-blockGraph b@(BCat {})    = gUnitOO b-blockGraph b@(BHead {})   = gUnitCO b-blockGraph b@(BTail {})   = gUnitOC b-blockGraph b@(BClosed {}) = gUnitCC b----- | Function 'graphMapBlocks' enables a change of representation of blocks,--- nodes, or both.  It lifts a polymorphic block transform into a polymorphic--- graph transform.  When the block representation stabilizes, a similar--- function should be provided for blocks.-graphMapBlocks :: forall block n block' n' e x .-                  (forall e x . block n e x -> block' n' e x)-               -> (Graph' block n e x -> Graph' block' n' e x)--graphMapBlocks f = map-  where map :: Graph' block n e x -> Graph' block' n' e x-        map GNil = GNil-        map (GUnit b) = GUnit (f b)-        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)---- | Function 'blockMapNodes' enables a change of nodes in a block.-blockMapNodes3 :: ( n C O -> n' C O-                  , n O O -> n' O O-                  , n O C -> n' O C)-               -> Block n e x -> Block n' e x-blockMapNodes3 (f, _, _) (BFirst n)     = BFirst (f n)-blockMapNodes3 (_, m, _) (BMiddle n)    = BMiddle (m n)-blockMapNodes3 (_, _, l) (BLast n)      = BLast (l n)-blockMapNodes3 fs (BCat x y)            = BCat (blockMapNodes3 fs x) (blockMapNodes3 fs y)-blockMapNodes3 fs@(_, m, _) (BHead x n) = BHead (blockMapNodes3 fs x) (m n)-blockMapNodes3 fs@(_, m, _) (BTail n x) = BTail (m n) (blockMapNodes3 fs x)-blockMapNodes3 fs (BClosed x y)         = BClosed (blockMapNodes3 fs x) (blockMapNodes3 fs y)--blockMapNodes :: (forall e x. n e x -> n' e x)-              -> (Block n e x -> Block n' e x)-blockMapNodes f = blockMapNodes3 (f, f, f)--------------------------------------------------------------------class LabelsPtr l where-  targetLabels :: l -> [Label]--instance NonLocal n => LabelsPtr (n e C) where-  targetLabels n = successors n--instance LabelsPtr Label where-  targetLabels l = [l]--instance LabelsPtr LabelSet where-  targetLabels = setElems--instance LabelsPtr l => LabelsPtr [l] where-  targetLabels = concatMap targetLabels----- | Traversal: 'postorder_dfs' returns a list of blocks reachable--- from the entry of enterable graph. The entry and exit are *not* included.--- The list has the following property:------	Say a "back reference" exists if one of a block's---	control-flow successors precedes it in the output list------	Then there are as few back references as possible------ The output is suitable for use in--- a forward dataflow problem.  For a backward problem, simply reverse--- the list.  ('postorder_dfs' is sufficiently tricky to implement that--- one doesn't want to try and maintain both forward and backward--- versions.)--postorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C]-preorder_dfs  :: NonLocal (block n) => Graph' block n O x -> [block n C C]---- | This is the most important traversal over this data structure.  It drops--- unreachable code and puts blocks in an order that is good for solving forward--- dataflow problems quickly.  The reverse order is good for solving backward--- dataflow problems quickly.  The forward order is also reasonably good for--- emitting instructions, except that it will not usually exploit Forrest--- Baskett's trick of eliminating the unconditional branch from a loop.  For--- that you would need a more serious analysis, probably based on dominators, to--- identify loop headers.------ The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'--- representation, when for most purposes the plain 'Graph' representation is--- more mathematically elegant (but results in more complicated code).------ Here's an easy way to go wrong!  Consider--- @---	A -> [B,C]---	B -> D---	C -> D--- @--- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.--- Better to get [A,B,C,D]---graphDfs :: (NonLocal (block n))-         => (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C])-         -> (Graph' block n O x -> [block n C C])-graphDfs _     (GNil)    = []-graphDfs _     (GUnit{}) = []-graphDfs order (GMany (JustO entry) body _) = order body entry setEmpty--postorder_dfs = graphDfs postorder_dfs_from_except-preorder_dfs  = graphDfs preorder_dfs_from_except--postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)-                          => LabelMap (block C C) -> e -> LabelSet -> [block C C]-postorder_dfs_from_except blocks b visited =- vchildren (get_children b) (\acc _visited -> acc) [] visited- where-   vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a-   vnode block cont acc visited =-        if setMember id visited then-            cont acc visited-        else-            let cont' acc visited = cont (block:acc) visited in-            vchildren (get_children block) cont' acc (setInsert 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 id blocks of-                      Just b -> b : rst-                      Nothing -> rst--postorder_dfs_from-    :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]-postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty---------------------------------------------------------------------data VM a = VM { unVM :: LabelSet -> (a, LabelSet) }-marked :: Label -> VM Bool-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 -> (setMember l v, v)-mark   l = VM $ \v -> ((), setInsert l v)--preorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)-                         => LabelMap (block C C) -> e -> LabelSet -> [block C C]-preorder_dfs_from_except blocks b visited =-    (fst $ unVM (children (get_children b)) visited) []-  where children [] = return id-        children (b:bs) = liftM2 (.) (visit b) (children bs)-        visit :: block C C -> VM (HL (block C C))-        visit b = do already <- marked (entryLabel b)-                     if already then return id-                      else do mark (entryLabel b)-                              bs <- children $ get_children b-                              return $ b `cons` bs-        get_children block = foldr add_id [] $ targetLabels block-        add_id id rst = case lookupFact id blocks of-                          Just b -> b : rst-                          Nothing -> rst--type HL a = [a] -> [a] -- Hughes list (constant-time concatenation)-cons :: a -> HL a -> HL a-cons a as tail = a : as tail--------------------------------------------------------------------labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x -> LabelSet-labelsDefined GNil      = setEmpty-labelsDefined (GUnit{}) = setEmpty-labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body-  where addEntry label _ labels = setInsert label labels-        exitLabel :: MaybeO x (block n C O) -> LabelSet-        exitLabel NothingO  = setEmpty-        exitLabel (JustO b) = setSingleton (entryLabel b)--labelsUsed :: forall block n e x. NonLocal (block n) => Graph' block n e x -> LabelSet-labelsUsed GNil      = setEmpty-labelsUsed (GUnit{}) = setEmpty-labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body -  where addTargets block labels = setInsertList (successors block) labels-        entryTargets :: MaybeO e (block n O C) -> LabelSet-        entryTargets NothingO = setEmpty-        entryTargets (JustO b) = addTargets b setEmpty--externalEntryLabels :: forall n .-                       NonLocal n => LabelMap (Block n C C) -> LabelSet-externalEntryLabels body = defined `setDifference` used-  where defined = labelsDefined g-        used = labelsUsed g-        g = GMany NothingO body NothingO

@@ -1,7 +0,0 @@-module Compiler.Hoopl.Wrappers {-# DEPRECATED "Use only if you know what you are doing and can preserve the 'respects fuel' invariant" #-}-  ( wrapFR, wrapFR2, wrapBR, wrapBR2-  )-where--import Compiler.Hoopl.Dataflow-

@@ -1,490 +0,0 @@-{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies  #-}---- | Utilities for clients of Hoopl, not used internally.--module Compiler.Hoopl.XUtil-  ( firstXfer, distributeXfer-  , distributeFact, distributeFactBwd-  , successorFacts-  , joinFacts-  , joinOutFacts -- deprecated-  , joinMaps-  , foldGraphNodes-  , foldBlockNodesF, foldBlockNodesB, foldBlockNodesF3, foldBlockNodesB3-  , tfFoldBlock-  , ScottBlock(ScottBlock), scottFoldBlock-  , fbnf3-  , blockToNodeList, blockOfNodeList-  , blockToNodeList'   -- alternate version using fold-  , blockToNodeList''  -- alternate version using scottFoldBlock-  , blockToNodeList''' -- alternate version using tfFoldBlock-  , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody-  , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx-  , noEntries-  , BlockResult(..), lookupBlock-  )-where--import qualified Data.Map as M-import Data.Maybe--import Compiler.Hoopl.Checkpoint-import Compiler.Hoopl.Collections-import Compiler.Hoopl.Dataflow-import Compiler.Hoopl.Graph-import Compiler.Hoopl.Label-import Compiler.Hoopl.Util----- | Forward dataflow analysis and rewriting for the special case of a Body.--- A set of entry points must be supplied; blocks not reachable from--- the set are thrown away.-analyzeAndRewriteFwdBody-   :: 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)---- | Backward dataflow analysis and rewriting for the special case of a Body.--- A set of entry points must be supplied; blocks not reachable from--- the set are thrown away.-analyzeAndRewriteBwdBody-   :: 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)--analyzeAndRewriteFwdBody pass en = mapBodyFacts (analyzeAndRewriteFwd pass (JustC en))-analyzeAndRewriteBwdBody pass en = mapBodyFacts (analyzeAndRewriteBwd pass (JustC en))--mapBodyFacts :: (Monad m)-    => (Graph n C C -> Fact C f   -> m (Graph n C C, Fact C f, MaybeO C f))-    -> (Body n      -> FactBase f -> m (Body n, FactBase f))--- ^ Internal utility; should not escape-mapBodyFacts anal b f = anal (GMany NothingO b NothingO) f >>= bodyFacts-  where -- the type constraint is needed for the pattern match;-        -- if it were not, we would use do-notation here.-    bodyFacts :: Monad m => (Graph n C C, Fact C f, MaybeO C f) -> m (Body n, Fact C f)-    bodyFacts (GMany NothingO body NothingO, fb, NothingO) = return (body, fb)--{--  Can't write:--     do (GMany NothingO body NothingO, fb, NothingO) <- anal (....) f-        return (body, fb)--  because we need an explicit type signature in order to do the GADT-  pattern matches on NothingO--}------ | Forward dataflow analysis and rewriting for the special case of a --- graph open at the entry.  This special case relieves the client--- 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. (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 --- graph open at the entry.  This special case relieves the client--- 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. (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.-noEntries :: MaybeC O Label-noEntries = NothingC--analyzeAndRewriteFwdOx pass g f  = analyzeAndRewriteFwd pass noEntries g f-analyzeAndRewriteBwdOx pass g fb = analyzeAndRewriteBwd pass noEntries g fb >>= strip-  where strip :: forall m a b c . Monad m => (a, b, MaybeO O c) -> m (a, b, c)-        strip (a, b, JustO c) = return (a, b, c)-------- | A utility function so that a transfer function for a first--- node can be given just a fact; we handle the lookup.  This--- function is planned to be made obsolete by changes in the dataflow--- interface.--firstXfer :: NonLocal n => (n C O -> f -> f) -> (n C O -> FactBase f -> f)-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-               => 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 = 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 = mapSingleton (entryLabel n) f---- | List of (unlabelled) facts from the successors of a last node-successorFacts :: NonLocal n => n O C -> FactBase f -> [f]-successorFacts n fb = [ f | id <- successors n, let Just f = lookupFact id fb ]---- | Join a list of facts.-joinFacts :: DataflowLattice f -> Label -> [f] -> f-joinFacts lat inBlock = foldr extend (fact_bot lat)-  where extend new old = snd $ fact_join lat inBlock (OldFact old) (NewFact new)--{-# DEPRECATED joinOutFacts-    "should be replaced by 'joinFacts lat l (successorFacts n f)'; as is, it uses the wrong Label" #-}--joinOutFacts :: (NonLocal node) => DataflowLattice f -> node O C -> FactBase f -> f-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]----- | It's common to represent dataflow facts as a map from variables--- to some fact about the locations. For these maps, the join--- operation on the map can be expressed in terms of the join on each--- element of the codomain:-joinMaps :: Ord k => JoinFun v -> JoinFun (M.Map k v)-joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldWithKey add (NoChange, old) new-  where -    add k new_v (ch, joinmap) =-      case M.lookup k joinmap of-        Nothing    -> (SomeChange, M.insert k new_v joinmap)-        Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of-                        (SomeChange, v') -> (SomeChange, M.insert k v' joinmap)-                        (NoChange,   _)  -> (ch, joinmap)------ | 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 -> 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 -> IndexedCO x c (IndexedCO e bc bo)-        block (BFirst  n)       = f n-        block (BMiddle n)       = m n bo-        block (BLast   n)       = l n bo-        block (b1 `BCat`    b2) = oblock b2 $ block b1-        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 -> 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-        oblock (n `BTail` b2)    = m n       `cat` oblock b2-        cat f f' = f' . f---type NodeList' e x n = (MaybeC e (n C O), [n O O], MaybeC x (n O C))-blockToNodeList''' ::-  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-    (h, ms', t) = tfFoldBlock (f, m, l) b z-    z :: NodeList' O O n-    z = (NothingC, [], NothingC)-    f :: n C O -> NodeList' C O n-    f n = (JustC n,  [], NothingC)-    m n (h, ms', t) = (h, n : ms', t)-    l n (h, ms', _) = (h, ms', JustC n)---{--data EitherCO' ex a b where-  LeftCO  :: a -> EitherCO' C a b-  RightCO :: b -> EitherCO' O a b--}--  -- should be done with a *backward* fold---- | More general fold--_unused :: Int-_unused = 3-  where _a = foldBlockNodesF3'' (Trips undefined undefined undefined)-        _b = foldBlockNodesF3'--data Trips n a b c = Trips { ff :: forall e . MaybeC e (n C O) -> a -> b-                           , fm :: n O O            -> b -> b-                           , fl :: forall x . MaybeC x (n O C) -> b -> c-                           }--foldBlockNodesF3'' :: forall n a b c .-                      Trips n a b c -> (forall e x . Block n e x -> a -> c)-foldBlockNodesF3'' trips = block-  where block :: Block n e x -> a -> c-        block (b1 `BClosed` b2) = foldCO b1 `cat` foldOC b2-        block (BFirst  node)    = ff trips (JustC node)  `cat` missingLast-        block (b @ BHead {})    = foldCO b `cat` missingLast-        block (BMiddle node)    = missingFirst `cat` fm trips node  `cat` missingLast-        block (b @ BCat {})     = missingFirst `cat` foldOO b `cat` missingLast-        block (BLast   node)    = missingFirst `cat` fl trips (JustC node)-        block (b @ BTail {})    = missingFirst `cat` foldOC b-        missingLast = fl trips NothingC-        missingFirst = ff trips NothingC-        foldCO :: Block n C O -> a -> b-        foldOO :: Block n O O -> b -> b-        foldOC :: Block n O C -> b -> c-        foldCO (BFirst n)   = ff trips (JustC n)-        foldCO (BHead b n)  = foldCO b `cat` fm trips n-        foldOO (BMiddle n)  = fm trips n-        foldOO (BCat b1 b2) = foldOO b1 `cat` foldOO b2-        foldOC (BLast n)    = fl trips (JustC n)-        foldOC (BTail n b)  = fm trips n `cat` foldOC b-        f `cat` g = g . f --data ScottBlock n a = ScottBlock-   { sb_first :: n C O -> a C O-   , sb_mid   :: n O O -> a O O-   , sb_last  :: n O C -> a O C-   , sb_cat   :: forall e x . a e O -> a O x -> a e x-   }--scottFoldBlock :: forall n a e x . ScottBlock n a -> Block n e x -> a e x-scottFoldBlock funs = block-  where block :: forall e x . Block n e x -> a e x-        block (BFirst n)  = sb_first  funs n-        block (BMiddle n) = sb_mid    funs n-        block (BLast   n) = sb_last   funs n-        block (BClosed b1 b2) = block b1 `cat` block b2-        block (BCat    b1 b2) = block b1 `cat` block b2-        block (BHead   b  n)  = block b  `cat` sb_mid funs n-        block (BTail   n  b)  = sb_mid funs n `cat` block b-        cat = sb_cat funs--newtype NodeList n e x-    = NL { unList :: (MaybeC e (n C O), [n O O] -> [n O O], MaybeC x (n O C)) }--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 -> 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 :: 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)-    where f n = NL (JustC n, id, NothingC)-          m n = NL (NothingC, (n:), NothingC)-          l n = NL (NothingC, id, JustC n)-          cat :: NodeList n e O -> NodeList n O x -> NodeList n e x-          NL (e, ms, NothingC) `cat` NL (NothingC, ms', x) = NL (e, ms . ms', x)-          finish (e, ms, x) = (e, ms [], x)----blockToNodeList' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))-blockToNodeList' b = unFNL $ foldBlockNodesF3''' ff fm fl b ()-  where ff n () = PNL (n, [])-        fm n (PNL (first, mids')) = PNL (first, n : mids')-        fl n (PNL (first, mids')) = FNL (first, reverse mids', n)--   -- newtypes for 'partial node list' and 'final node list'-newtype PNL n e   = PNL (MaybeC e (n C O), [n O O])-newtype FNL n e x = FNL {unFNL :: (MaybeC e (n C O), [n O O], MaybeC x (n O C))}--foldBlockNodesF3''' :: forall n a b c .-                       (forall e   . MaybeC e (n C O) -> a   -> b e)-                    -> (forall e   .           n O O  -> b e -> b e)-                    -> (forall e x . MaybeC x (n O C) -> b e -> c e x)-                    -> (forall e x . Block n e x      -> a   -> c e x)-foldBlockNodesF3''' ff fm fl = block-  where block   :: forall e x . Block n e x -> a   -> c e x-        blockCO ::              Block n C O -> a   -> b C-        blockOO :: forall e .   Block n O O -> b e -> b e-        blockOC :: forall e .   Block n O C -> b e -> c e C-        block (b1 `BClosed` b2) = blockCO b1       `cat` blockOC b2-        block (BFirst  node)    = ff (JustC node)  `cat` fl NothingC-        block (b @ BHead {})    = blockCO b        `cat` fl NothingC-        block (BMiddle node)    = ff NothingC `cat` fm node   `cat` fl NothingC-        block (b @ BCat {})     = ff NothingC `cat` blockOO b `cat` fl NothingC-        block (BLast   node)    = ff NothingC `cat` fl (JustC node)-        block (b @ BTail {})    = ff NothingC `cat` blockOC b-        blockCO (BFirst n)      = ff (JustC n)-        blockCO (BHead b n)     = blockCO b `cat` fm n-        blockOO (BMiddle n)     = fm n-        blockOO (BCat b1 b2)    = blockOO b1 `cat` blockOO b2-        blockOC (BLast n)       = fl (JustC n)-        blockOC (BTail n b)     = fm n `cat` blockOC b-        f `cat` g = g . f ----- | The following function is easy enough to define but maybe not so useful-foldBlockNodesF3' :: forall n a b c .-                   ( n C O -> a -> b-                   , n O O -> b -> b-                   , n O C -> b -> c)-                   -> (a -> b) -- called iff there is no first node-                   -> (b -> c) -- called iff there is no last node-                   -> (forall e x . Block n e x -> a -> c)-foldBlockNodesF3' (ff, fm, fl) missingFirst missingLast = block-  where block   :: forall e x . Block n e x -> a -> c-        blockCO ::              Block n C O -> a -> b-        blockOO ::              Block n O O -> b -> b-        blockOC ::              Block n O C -> b -> c-        block (b1 `BClosed` b2) = blockCO b1 `cat` blockOC b2-        block (BFirst  node)    = ff node  `cat` missingLast-        block (b @ BHead {})    = blockCO b `cat` missingLast-        block (BMiddle node)    = missingFirst `cat` fm node  `cat` missingLast-        block (b @ BCat {})     = missingFirst `cat` blockOO b `cat` missingLast-        block (BLast   node)    = missingFirst `cat` fl node-        block (b @ BTail {})    = missingFirst `cat` blockOC b-        blockCO (BFirst n)   = ff n-        blockCO (BHead b n)  = blockCO b `cat` fm n-        blockOO (BMiddle n)  = fm n-        blockOO (BCat b1 b2) = blockOO b1 `cat` blockOO b2-        blockOC (BLast n)    = fl n-        blockOC (BTail n b)  = fm n `cat` blockOC b-        f `cat` g = g . f ---- | Fold a function over every node in a block, forward or backward.--- The fold function must be polymorphic in the shape of the nodes.-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 -> 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 -> 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 -> 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 -> 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.--foldGraphNodes :: forall n a .-                  (forall e x . n e x       -> a -> a)-               -> (forall e x . Graph n e x -> a -> a)---foldBlockNodesF3 (ff, fm, fl) = block-  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-        block (b1 `BCat`    b2) = block b1 `cat` block b2-        block (b1 `BClosed` b2) = block b1 `cat` block b2-        block (b1 `BHead` n)    = block b1 `cat` fm n-        block (n `BTail` b2)    = fm n `cat` block b2-        cat f f' = f' . f-foldBlockNodesF f = foldBlockNodesF3 (f, f, f)--foldBlockNodesB3 (ff, fm, fl) = block-  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-        block (b1 `BCat`    b2) = block b1 `cat` block b2-        block (b1 `BClosed` b2) = block b1 `cat` block b2-        block (b1 `BHead` n)    = block b1 `cat` fm n-        block (n `BTail` b2)    = fm n `cat` block b2-        cat f f' = f . f'-foldBlockNodesB f = foldBlockNodesB3 (f, f, f)---foldGraphNodes f = graph-    where graph :: forall e x . Graph n e x -> a -> a-          lift  :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a)--          graph GNil              = id-          graph (GUnit b)         = block b-          graph (GMany e b x)     = lift block e . body b . lift block x-          body :: Body n -> a -> a-          body bdy                = \a -> mapFold block a bdy-          lift _ NothingO         = id-          lift f (JustO thing)    = f thing--          block = foldBlockNodesF f--{-# DEPRECATED blockToNodeList, blockOfNodeList -  "What justifies these functions?  Can they be eliminated?  Replaced with folds?" #-}------ | Convert a block to a list of nodes. The entry and exit node--- is or is not present depending on the shape of the block.------ The blockToNodeList function cannot be currently expressed using--- 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.-blockToNodeList :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))-blockToNodeList block = case block of-  BFirst n    -> (JustC n, [], NothingC)-  BMiddle n   -> (NothingC, [n], NothingC)-  BLast n     -> (NothingC, [], JustC n)-  BCat {}     -> (NothingC, foldOO block [], NothingC)-  BHead x n   -> case foldCO x [n] of (f, m) -> (f, m, NothingC)-  BTail n x   -> case foldOC x of (m, l) -> (NothingC, n : m, l)-  BClosed x y -> case foldOC y of (m, l) -> case foldCO x m of (f, m') -> (f, m', l)-  where foldCO :: Block n C O -> [n O O] -> (MaybeC C (n C O), [n O O])-        foldCO (BFirst n) m  = (JustC n, m)-        foldCO (BHead x n) m = foldCO x (n : m)--        foldOO :: Block n O O -> [n O O] -> [n O O]-        foldOO (BMiddle n) acc = n : acc-        foldOO (BCat x y) acc  = foldOO x $ foldOO y acc--        foldOC :: Block n O C -> ([n O O], MaybeC C (n O C))-        foldOC (BLast n)   = ([], JustC n)-        foldOC (BTail n x) = case foldOC x of (m, l) -> (n : m, l)---- | Convert a list of nodes to a block. The entry and exit node--- must or must not be present depending on the shape of the block.-blockOfNodeList :: (MaybeC e (n C O), [n O O], MaybeC x (n O C)) -> Block n e x-blockOfNodeList (NothingC, [], NothingC) = error "No nodes to created block from in blockOfNodeList"-blockOfNodeList (NothingC, m, NothingC)  = foldr1 BCat (map BMiddle m)-blockOfNodeList (NothingC, m, JustC l)   = foldr BTail (BLast l) m-blockOfNodeList (JustC f, m, NothingC)   = foldl BHead (BFirst f) m-blockOfNodeList (JustC f, m, JustC l)    = BClosed (BFirst f) $ foldr BTail (BLast l) m--data BlockResult n x where-  NoBlock   :: BlockResult n x-  BodyBlock :: Block n C C -> BlockResult n x-  ExitBlock :: Block n C O -> BlockResult n O--lookupBlock :: NonLocal n => Graph n e x -> Label -> BlockResult n x-lookupBlock (GMany _ _ (JustO exit)) lbl-  | entryLabel exit == lbl = ExitBlock exit-lookupBlock (GMany _ body _) lbl =-  case mapLookup lbl body of-    Just b  -> BodyBlock b-    Nothing -> NoBlock-lookupBlock GNil      _ = NoBlock-lookupBlock (GUnit _) _ = NoBlock

@@ -1,35 +1,30 @@-This is Hoopl, a higher-order optimization library.-There are two unpublished papers describing Hoopl:+This repository contains things related to -  Hoopl: Dataflow Optimization Made Simple-  Hoopl: A Modular, Reusable Library for Dataflow Analysis and Transformation+              Hoopl: A Higher-Order OPtimization Library -The second such paper is attached to this package.+** The closest thing we have to a SAMPLE CLIENT is in ./testing ** -The version number is split into four parts:+Directory     Contents -  3.   Third major body plan (phylum)-  7.   Seventh iteration (roughly) of data structures-  2.   Major version; changes when clients must change-  1.   Minor version; changes when clients can stay the same+paper/        A paper about Hoopl+prototypes/   A sampling of prototypes and early designs+src/          The current official sources to the Cabal package+testing/      Tests, including a sample client.  See ./testing/README. +To build the library, change to the src directory and run -Version 3.7.3.3 has fixed known bugs.+  cabal configure --prefix=$HOME --user   # we have no idea what this means+  cabal build+  cabal install --enable-documentation -Version 3.7.8.0 will be the last version uploaded to Hackage for some time.-This library is undergoing *very* rapid development, and we ask that you-get the most recent version from our public git repository:+You'll need a Haskell Platform, which should include appropriate+versions of Cabal and GHC. -  git clone -o tufts git://ghc.cs.tufts.edu/hoopl/hoopl.git+To upload to Hackage, -If you are not familiar with git, we recommend the tutorial 'Git Magic'-by Ben Lynn.  To get some ideas about how to use git effectively,+  cabal sdist+  cabal upload dist/something.tar.gz -  http://whygitisbetterthanx.com/  -is also useful. -If you've been given an account at Tufts with write privileges to the-git repository, you'll want to use a different URL:--  git clone -o tufts linux.cs.tufts.edu:/r/ghc/www/hoopl/hoopl.git+  

@@ -1,6 +1,7 @@ Name:                hoopl-Version:             3.8.6.0+Version:             3.8.7.0 -- version 3.8.6.0 is the version that goes with the camera-ready Haskell'10 paper+-- version 3.8.7.0 works with GHC 7 Description:         Higher-order optimization library License:             BSD3 License-file:        LICENSE@@ -42,6 +43,7 @@                        Compiler.Hoopl.Util                        Compiler.Hoopl.XUtil   ghc-options:       -Wall -fno-warn-name-shadowing+  hs-source-dirs:  src   Source-repository head

binary file changed (216881 → 279781 bytes)

@@ -0,0 +1,37 @@+module Compiler.Hoopl+  ( module Compiler.Hoopl.Graph+  , 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+  , module Compiler.Hoopl.Combinators+  , module Compiler.Hoopl.Fuel+  , module Compiler.Hoopl.Unique+  , module Compiler.Hoopl.Util+  , module Compiler.Hoopl.Debug+  , module Compiler.Hoopl.Show+  )+where++import Compiler.Hoopl.Checkpoint+import Compiler.Hoopl.Collections+import Compiler.Hoopl.Combinators+import Compiler.Hoopl.Dataflow hiding ( wrapFR, wrapFR2, wrapBR, wrapBR2+                                      )+import Compiler.Hoopl.Debug+import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel, FuelMonadT)+import Compiler.Hoopl.Graph hiding +   ( Body+   , BCat, BHead, BTail, BClosed -- OK to expose BFirst, BMiddle, BLast+   )+import Compiler.Hoopl.Graph (Body)+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 (uniqueToInt)+import Compiler.Hoopl.XUtil

@@ -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 () +

@@ -0,0 +1,85 @@+{- Baseclasses for Map-like and Set-like collections inspired by containers. -}++{-# LANGUAGE TypeFamilies #-}+module Compiler.Hoopl.Collections ( IsSet(..)+                                  , setInsertList, setDeleteList, setUnions+                                  , IsMap(..)+                                  , mapInsertList, mapDeleteList, mapUnions+                                  ) where++import Data.List (foldl', foldl1')++class IsSet set where+  type ElemOf set++  setNull :: set -> Bool+  setSize :: set -> Int+  setMember :: ElemOf set -> set -> Bool++  setEmpty :: set+  setSingleton :: ElemOf set -> set+  setInsert :: ElemOf set -> set -> set+  setDelete :: ElemOf set -> set -> set++  setUnion :: set -> set -> set+  setDifference :: set -> set -> set+  setIntersection :: set -> set -> set+  setIsSubsetOf :: set -> set -> Bool++  setFold :: (ElemOf set -> b -> b) -> b -> set -> b++  setElems :: set -> [ElemOf set]+  setFromList :: [ElemOf set] -> set++-- Helper functions for IsSet class+setInsertList :: IsSet set => [ElemOf set] -> set -> set+setInsertList keys set = foldl' (flip setInsert) set keys++setDeleteList :: IsSet set => [ElemOf set] -> set -> set+setDeleteList keys set = foldl' (flip setDelete) set keys++setUnions :: IsSet set => [set] -> set+setUnions [] = setEmpty+setUnions sets = foldl1' setUnion sets+++class IsMap map where+  type KeyOf map++  mapNull :: map a -> Bool+  mapSize :: map a -> Int+  mapMember :: KeyOf map -> map a -> Bool+  mapLookup :: KeyOf map -> map a -> Maybe a+  mapFindWithDefault :: a -> KeyOf map -> map a -> a++  mapEmpty :: map a+  mapSingleton :: KeyOf map -> a -> map a+  mapInsert :: KeyOf map -> a -> map a -> map a+  mapDelete :: KeyOf map -> map a -> map a++  mapUnion :: map a -> map a -> map a+  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a+  mapDifference :: map a -> map a -> map a+  mapIntersection :: map a -> map a -> map a+  mapIsSubmapOf :: Eq a => map a -> map a -> Bool++  mapMap :: (a -> b) -> map a -> map b+  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b+  mapFold :: (a -> b -> b) -> b -> map a -> b+  mapFoldWithKey :: (KeyOf map -> a -> b -> b) -> b -> map a -> b++  mapElems :: map a -> [a]+  mapKeys :: map a -> [KeyOf map]+  mapToList :: map a -> [(KeyOf map, a)]+  mapFromList :: [(KeyOf map, a)] -> map a++-- Helper functions for IsMap class+mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a+mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs++mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a+mapDeleteList keys map = foldl' (flip mapDelete) map keys++mapUnions :: IsMap map => [map a] -> map a+mapUnions [] = mapEmpty+mapUnions maps = foldl1' mapUnion maps

@@ -0,0 +1,232 @@+{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables, GADTs #-}++module Compiler.Hoopl.Combinators+  ( thenFwdRw+  , deepFwdRw3, deepFwdRw, iterFwdRw+  , thenBwdRw+  , deepBwdRw3, deepBwdRw, iterBwdRw+  , pairFwd, pairBwd, pairLattice+  )++where++import Control.Monad+import Data.Maybe++import Compiler.Hoopl.Collections+import Compiler.Hoopl.Dataflow+import Compiler.Hoopl.Fuel+import Compiler.Hoopl.Graph (Graph, C, O, Shape(..))+import Compiler.Hoopl.Label++----------------------------------------------------------------++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+deepFwdRw f = deepFwdRw3 f f f++-- N.B. rw3, rw3', and rw3a are triples of functions.+-- But rw and rw' are single functions.+-- @ start comb1.tex+thenFwdRw :: forall m n f. Monad m +          => FwdRewrite m n f +          -> FwdRewrite m n f +          -> FwdRewrite m n f+-- @ end comb1.tex+thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3'+ where+  thenrw :: forall m1 e x t t1.+            Monad m1 =>+            (t -> t1 -> m1 (Maybe (Graph n e x, FwdRewrite m n f)))+            -> (t -> t1 -> m1 (Maybe (Graph n e x, FwdRewrite m n f)))+            -> t+            -> t1+            -> m1 (Maybe (Graph n e x, FwdRewrite m n f))+  thenrw rw rw' n f = rw n f >>= fwdRes+     where fwdRes Nothing   = rw' n f+           fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr++-- @ start iterf.tex+iterFwdRw :: forall m n f. Monad m +          => FwdRewrite m n f +          -> FwdRewrite m n f+-- @ end iterf.tex+iterFwdRw rw3 = wrapFR iter rw3+ where iter :: forall a m1 m2 e x t.+               (Monad m2, Monad m1) =>+               (t -> a -> m1 (m2 (Graph n e x, FwdRewrite m n f)))+               -> t+               -> a+               -> m1 (m2 (Graph n e x, FwdRewrite m n f))+       iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n++-- | Function inspired by 'rew' in the paper+_frewrite_cps :: Monad m+             => ((Graph n e x, FwdRewrite m n f) -> m a)+             -> m a+             -> (forall e x . n e x -> f -> m (Maybe (Graph n e x, FwdRewrite m n f)))+             -> n e x+             -> f+             -> m a+_frewrite_cps j n rw node f =+    do mg <- rw node f+       case mg of Nothing -> n+                  Just gr -> j gr++++-- | Function inspired by 'add' in the paper+fadd_rw :: Monad m+       => FwdRewrite m n f+       -> (Graph n e x, FwdRewrite m n f)+       -> (Graph n e x, FwdRewrite m n f)+fadd_rw rw2 (g, rw1) = (g, rw1 `thenFwdRw` rw2)++----------------------------------------------------------------++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+deepBwdRw3 f m l = iterBwdRw $ mkBRewrite3 f m l+deepBwdRw  f = deepBwdRw3 f f f+++thenBwdRw :: forall m n f. Monad m => BwdRewrite m n f -> BwdRewrite m n f -> BwdRewrite m n f+thenBwdRw rw1 rw2 = wrapBR2 f rw1 rw2+  where f :: forall t t1 t2 m1 e x.+             Monad m1 =>+             t+             -> (t1 -> t2 -> m1 (Maybe (Graph n e x, BwdRewrite m n f)))+             -> (t1 -> t2 -> m1 (Maybe (Graph n e x, BwdRewrite m n f)))+             -> t1+             -> t2+             -> m1 (Maybe (Graph n e x, BwdRewrite m n f))+        f _ rw1 rw2' n f = do+          res1 <- rw1 n f+          case res1 of+            Nothing -> rw2' n f+            Just gr -> return $ Just $ badd_rw rw2 gr++iterBwdRw :: forall m n f. Monad m => BwdRewrite m n f -> BwdRewrite m n f+iterBwdRw rw = wrapBR f rw+  where f :: forall t m1 m2 e x t1 t2.+             (Monad m2, Monad m1) =>+             t+             -> (t1 -> t2 -> m1 (m2 (Graph n e x, BwdRewrite m n f)))+             -> t1+             -> t2+             -> m1 (m2 (Graph n e x, BwdRewrite m n f))+        f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f)++-- | Function inspired by 'add' in the paper+badd_rw :: Monad m+       => BwdRewrite m n f+       -> (Graph n e x, BwdRewrite m n f)+       -> (Graph n e x, BwdRewrite m n f)+badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2)+++-- @ start pairf.tex+pairFwd :: forall m n f f'. Monad m+        => FwdPass m n f+        -> FwdPass m n f' +        -> FwdPass m n (f, f')+-- @ end pairf.tex+pairFwd pass1 pass2 = FwdPass lattice transfer rewrite+  where+    lattice = pairLattice (fp_lattice pass1) (fp_lattice pass2)+    transfer = mkFTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)+      where+        tf :: forall t t1 t2 t3 t4.+              (t4 -> t -> t2) -> (t4 -> t1 -> t3) -> t4 -> (t, t1) -> (t2, t3)+        tf  t1 t2 n (f1, f2) = (t1 n f1, t2 n f2)+        tfb t1 t2 n (f1, f2) = mapMapWithKey withfb2 fb1+          where fb1 = t1 n f1+                fb2 = t2 n f2+                withfb2 :: forall t. Label -> t -> (t, f')+                withfb2 l f = (f, fromMaybe bot2 $ lookupFact l fb2)+                bot2 = fact_bot (fp_lattice pass2)+        (tf1, tm1, tl1) = getFTransfer3 (fp_transfer pass1)+        (tf2, tm2, tl2) = getFTransfer3 (fp_transfer pass2)+    rewrite = lift fst (fp_rewrite pass1) `thenFwdRw` lift snd (fp_rewrite pass2) +      where+        lift :: forall f m' n' f'.+                Monad m' =>+                (f' -> f) -> FwdRewrite m' n' f -> FwdRewrite m' n' f'+        lift proj = wrapFR project+          where project :: forall m m1 t t1.+                          (Monad m1, Monad m) =>+                          (t1 -> f -> m (m1 (t, FwdRewrite m' n' f)))+                          -> t1+                          -> f'+                          -> m (m1 (t, FwdRewrite m' n' f'))+                project rw = \n pair -> liftM (liftM repair) $ rw n (proj pair)+                repair :: forall t.+                          (t, FwdRewrite m' n' f) -> (t, FwdRewrite m' n' f')+                repair (g, rw') = (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+  where+    lattice = pairLattice (bp_lattice pass1) (bp_lattice pass2)+    transfer = mkBTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)+      where+        tf :: (t4 -> t -> t2) -> (t4 -> t1 -> t3) -> t4 -> (t, t1) -> (t2, t3)+        tf  t1 t2 n (f1, f2) = (t1 n f1, t2 n f2)+        tfb :: IsMap map =>+               (t2 -> map a -> t)+               -> (t2 -> map b -> t1)+               -> t2+               -> map (a, b)+               -> (t, t1)+        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 = lift fst (bp_rewrite pass1) `thenBwdRw` lift snd (bp_rewrite pass2) +      where+       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 (Graph n e x, BwdRewrite m n f1)))+               -> (n e x ->+                       Fact x (f,f') -> m (Maybe (Graph n e x, BwdRewrite m n (f,f'))))+              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 :: forall t.+                        (t, BwdRewrite m n f1) -> (t, BwdRewrite m n (f, f'))+              repair (g, rw') = (g, lift proj rw')+                -- XXX specialize repair so that the cost+                -- of discriminating is one per combinator not one+                -- per rewrite++pairLattice :: forall f f' .+               DataflowLattice f -> DataflowLattice f' -> DataflowLattice (f, f')+pairLattice l1 l2 =+  DataflowLattice+    { fact_name = fact_name l1 ++ " x " ++ fact_name l2+    , fact_bot  = (fact_bot l1, fact_bot l2)+    , fact_join = join+    }+  where+    join lbl (OldFact (o1, o2)) (NewFact (n1, n2)) = (c', (f1, f2))+      where (c1, f1) = fact_join l1 lbl (OldFact o1) (NewFact n1)+            (c2, f2) = fact_join l2 lbl (OldFact o2) (NewFact n2)+            c' = case (c1, c2) of+                   (NoChange, NoChange) -> NoChange+                   _                    -> SomeChange

@@ -0,0 +1,821 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-}++module Compiler.Hoopl.Dataflow+  ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact, mkFactBase+  , ChangeFlag(..), changeIf+  , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3+  -- * Respecting Fuel++  -- $fuel+  , FwdRewrite,  mkFRewrite,  mkFRewrite3,  getFRewrite3, noFwdRewrite+  , wrapFR, wrapFR2+  , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3+  , wrapBR, wrapBR2+  , BwdRewrite,  mkBRewrite,  mkBRewrite3,  getBRewrite3, noBwdRewrite+  , analyzeAndRewriteFwd,  analyzeAndRewriteBwd+  )+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+                                           -- and include definition in paper+import qualified Compiler.Hoopl.GraphUtil as U+import Compiler.Hoopl.Label+import Compiler.Hoopl.Util++-----------------------------------------------------------------------------+--              DataflowLattice+-----------------------------------------------------------------------------++data DataflowLattice a = DataflowLattice  + { fact_name       :: String          -- Documentation+ , fact_bot        :: a               -- Lattice bottom element+ , fact_join       :: JoinFun a       -- Lattice join plus change flag+                                      -- (changes iff result > old fact)+ }+-- ^ A transfer function might want to use the logging flag+-- to control debugging, as in for example, it updates just one element+-- in a big finite map.  We don't want Hoopl to show the whole fact,+-- and only the transfer function knows exactly what changed.++type JoinFun a = Label -> OldFact a -> NewFact a -> (ChangeFlag, a)+  -- the label argument is for debugging purposes only+newtype OldFact a = OldFact a+newtype NewFact a = NewFact a++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 :: forall f. DataflowLattice f -> [(Label, f)] -> FactBase f+mkFactBase lattice = foldl add mapEmpty+  where add :: FactBase f -> (Label, f) -> FactBase f+        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+-----------------------------------------------------------------------------++data FwdPass m n f+  = FwdPass { fp_lattice  :: DataflowLattice f+            , fp_transfer :: FwdTransfer n f+            , fp_rewrite  :: FwdRewrite m n f }++newtype FwdTransfer n f +  = FwdTransfer3 { getFTransfer3 ::+                     ( n C O -> f -> f+                     , n O O -> f -> f+                     , n O C -> f -> FactBase f+                     ) }++newtype FwdRewrite m n f   -- see Note [Respects Fuel]+  = FwdRewrite3 { getFRewrite3 ::+                    ( n C O -> f -> m (Maybe (Graph n C O, FwdRewrite m n f))+                    , n O O -> f -> m (Maybe (Graph n O O, FwdRewrite m n f))+                    , n O C -> f -> m (Maybe (Graph n O C, FwdRewrite m n f))+                    ) }++wrapFR :: (forall e x. (n  e x -> f  -> m  (Maybe (Graph n  e x, FwdRewrite m  n  f )))+                    -> (n' e x -> f' -> m' (Maybe (Graph n' e x, FwdRewrite m' n' f')))+          )+            -- ^ 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 (Graph n1 e x, FwdRewrite m1 n1 f1))) ->+                   (n2 e x -> f2 -> m2 (Maybe (Graph n2 e x, FwdRewrite m2 n2 f2))) ->+                   (n3 e x -> f3 -> m3 (Maybe (Graph n3 e x, FwdRewrite m3 n3 f3)))+     )+            -- ^ 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)+             -> FwdTransfer n f+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 :: forall m n f. 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+mkFRewrite3 f m l = FwdRewrite3 (lift f, lift m, lift l)+  where lift :: forall t t1 a. (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe (a, FwdRewrite m n f))+        lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact)+        asRew :: forall t. t -> (t, FwdRewrite m n f)+        asRew g = (g, noFwdRewrite)++noFwdRewrite :: Monad m => FwdRewrite m n f+noFwdRewrite = FwdRewrite3 (noRewrite, noRewrite, noRewrite)++noRewrite :: Monad m => a -> b -> m (Maybe c)+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+++type family   Fact x f :: *+type instance Fact C f = FactBase f+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. (CheckpointMonad m, NonLocal n, LabelsPtr entries)+   => FwdPass m n f+   -> MaybeC e entries+   -> Graph n e x -> Fact e f+   -> m (Graph n e x, FactBase f, MaybeO x f)+analyzeAndRewriteFwd pass entries g f =+  do (rg, fout) <- arfGraph pass (fmap targetLabels entries) g f+     let (g', fb) = normalizeGraph rg+     return (g', fb, distinguishedExitFact g' fout)++distinguishedExitFact :: forall n e x f . Graph n e x -> Fact x f -> MaybeO x f+distinguishedExitFact g f = maybe g+    where maybe :: Graph n e x -> MaybeO x f+          maybe GNil       = JustO f+          maybe (GUnit {}) = JustO f+          maybe (GMany _ _ x) = case x of NothingO -> NothingO+                                          JustO _  -> JustO f++----------------------------------------------------------------+--       Forward Implementation+----------------------------------------------------------------++type Entries e = MaybeC e [Label]++arfGraph :: forall m n f e x .+            (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+    {- nested type synonyms would be so lovely here +    type ARF  thing = forall e x . thing e x -> f        -> m (DG f n e x, Fact x f)+    type ARFX thing = forall e x . thing e x -> Fact e f -> m (DG f n e x, Fact x f)+    -}+    graph ::              Graph n e x -> Fact e f -> m (DG f n e x, Fact x f)+-- @ start block.tex -2+    block :: forall e x . +             Block n e x -> f -> m (DG f n e x, Fact x f)+-- @ end block.tex+-- @ start node.tex -4+    node :: forall e x . (ShapeLifter e x) +         => n e x -> f -> m (DG f n e x, Fact x f)+-- @ end node.tex+-- @ start bodyfun.tex+    body  :: [Label] -> LabelMap (Block n C C)+          -> Fact C f -> m (DG f n C C, Fact C f)+-- @ end bodyfun.tex+                    -- Outgoing factbase is restricted to Labels *not* in+                    -- in the Body; the facts for Labels *in*+                    -- the Body are in the 'DG f n C C'+-- @ start cat.tex -2+    cat :: forall e a x f1 f2 f3. +           (f1 -> m (DG f n e a, f2))+        -> (f2 -> m (DG f n a x, f3))+        -> (f1 -> m (DG f n e x, f3))+-- @ end cat.tex++    graph GNil            = \f -> return (dgnil, f)+    graph (GUnit blk)     = block blk+    graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x+     where+      ebcat :: MaybeO e (Block n O C) -> Body n -> Fact e f -> m (DG f n e C, Fact C f)+      exit  :: MaybeO x (Block n C O)           -> Fact C f -> m (DG f n C x, Fact x f)+      exit (JustO blk) = arfx block blk+      exit NothingO    = \fb -> return (dgnilC, fb)+      ebcat entry bdy = c entries entry+       where c :: MaybeC e [Label] -> MaybeO e (Block n O C)+                -> Fact e f -> m (DG f n e C, Fact C f)+             c NothingC (JustO entry)   = block entry `cat` body (successors entry) bdy+             c (JustC entries) NothingO = body entries bdy+             c _ _ = error "bogus GADT pattern match failure"++    -- Lift from nodes to blocks+-- @ start block.tex -2+    block (BFirst  n)  = node n+    block (BMiddle n)  = node n+    block (BLast   n)  = node n+    block (BCat b1 b2) = block b1 `cat` block b2+-- @ end block.tex+    block (BHead h n)  = block h  `cat` node n+    block (BTail n t)  = node  n  `cat` block t+    block (BClosed h t)= block h  `cat` block t++-- @ start node.tex -4+    node n f+     = do { grw <- frewrite pass n f+          ; case grw of+              Nothing -> return ( singletonDG f n+                                , ftransfer pass n f )+              Just (g, rw) ->+                  let pass' = pass { fp_rewrite = rw }+                      f'    = fwdEntryFact n f+                  in  arfGraph pass' (fwdEntryLabel n) g f' }++-- @ end node.tex++    -- | Compose fact transformers and concatenate the resulting+    -- rewritten graphs.+    {-# INLINE cat #-} +-- @ start cat.tex -2+    cat ft1 ft2 f = do { (g1,f1) <- ft1 f+                       ; (g2,f2) <- ft2 f1+                       ; return (g1 `dgSplice` g2, f2) }+-- @ end cat.tex+    arfx :: forall thing x .+            NonLocal thing+         => (thing C x ->        f -> m (DG f n C x, Fact x f))+         -> (thing C x -> Fact C f -> m (DG f n C x, Fact x f))+    arfx arf thing fb = +      arf thing $ fromJust $ lookupFact (entryLabel thing) $ joinInFacts lattice fb+     where lattice = fp_lattice pass+     -- joinInFacts adds debugging information+++                    -- Outgoing factbase is restricted to Labels *not* in+                    -- in the Body; the facts for Labels *in*+                    -- 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+      where+        blocks  = forwardBlockList entries blockmap+        lattice = fp_lattice pass+        do_block :: forall x. Block n C x -> FactBase f -> m (DG f n C x, Fact x f)+        do_block b fb = block b entryFact+          where entryFact = getFact lattice (entryLabel b) fb+-- @ end bodyfun.tex+++-- Join all the incoming facts with bottom.+-- 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 (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)+                 => entry -> Body n -> [Block n C C]+-- This produces a list of blocks in order suitable for forward analysis,+-- along with the list of Labels it may depend on for facts.+forwardBlockList entries blks = postorder_dfs_from blks entries++-----------------------------------------------------------------------------+--              Backward analysis and rewriting: the interface+-----------------------------------------------------------------------------++data BwdPass m n f+  = BwdPass { bp_lattice  :: DataflowLattice f+            , bp_transfer :: BwdTransfer n f+            , bp_rewrite  :: BwdRewrite m n f }++newtype BwdTransfer n f +  = BwdTransfer3 { getBTransfer3 ::+                     ( n C O -> f          -> f+                     , n O O -> f          -> f+                     , n O C -> FactBase f -> f+                     ) }+newtype BwdRewrite m n f +  = BwdRewrite3 { getBRewrite3 ::+                    ( n C O -> f          -> m (Maybe (Graph n C O, BwdRewrite m n f))+                    , n O O -> f          -> m (Maybe (Graph n O O, BwdRewrite m n f))+                    , n O C -> FactBase f -> m (Maybe (Graph n O C, BwdRewrite m n f))+                    ) }++wrapBR :: (forall e x .+                Shape x +             -> (n  e x -> Fact x f  -> m  (Maybe (Graph n  e x, BwdRewrite m  n  f )))+             -> (n' e x -> Fact x f' -> m' (Maybe (Graph n' e x, BwdRewrite m' n' f')))+          )+            -- ^ 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 (Graph n1 e x, BwdRewrite m1 n1 f1)))+            -> (n2 e x -> Fact x f2 -> m2 (Maybe (Graph n2 e x, BwdRewrite m2 n2 f2)))+            -> (n3 e x -> Fact x f3 -> m3 (Maybe (Graph n3 e x, BwdRewrite m3 n3 f3))))+            -- ^ 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+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 :: forall m n f. 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+mkBRewrite3 f m l = BwdRewrite3 (lift f, lift m, lift l)+  where lift :: forall t t1 a. (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe (a, BwdRewrite m n f))+        lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact)+        asRew :: t -> (t, BwdRewrite m n f)+        asRew g = (g, noBwdRewrite)++noBwdRewrite :: Monad m => BwdRewrite m n f+noBwdRewrite = BwdRewrite3 (noRewrite, noRewrite, noRewrite)++-- | 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 = mkBRewrite3 f f f+++-----------------------------------------------------------------------------+--              Backward implementation+-----------------------------------------------------------------------------++arbGraph :: forall m n f e x .+            (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+    {- nested type synonyms would be so lovely here +    type ARB  thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, f)+    type ARBX thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, Fact e f)+    -}+    graph ::              Graph n e x -> Fact x f -> m (DG f n e x, Fact e f)+    block :: forall e x . Block n e x -> Fact x f -> m (DG f n e x, f)+    node  :: forall e x . (ShapeLifter e x) +                       => n e x       -> Fact x f -> m (DG f n e x, f)+    body  :: [Label] -> Body n -> Fact C f -> m (DG f n C C, Fact C f)+    cat :: forall e a x info info' info''.+           (info' -> m (DG f n e a, info''))+        -> (info  -> m (DG f n a x, info'))+        -> (info  -> m (DG f n e x, info''))++    graph GNil            = \f -> return (dgnil, f)+    graph (GUnit blk)     = block blk+    graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x+     where+      ebcat :: MaybeO e (Block n O C) -> Body n -> Fact C f -> m (DG f n e C, Fact e f)+      exit  :: MaybeO x (Block n C O)           -> Fact x f -> m (DG f n C x, Fact C f)+      exit (JustO blk) = arbx block blk+      exit NothingO    = \fb -> return (dgnilC, fb)+      ebcat entry bdy = c entries entry+       where c :: MaybeC e [Label] -> MaybeO e (Block n O C)+                -> Fact C f -> m (DG f n e C, Fact e f)+             c NothingC (JustO entry)   = block entry `cat` body (successors entry) bdy+             c (JustC entries) NothingO = body entries bdy+             c _ _ = error "bogus GADT pattern match failure"++    -- Lift from nodes to blocks+    block (BFirst  n)  = node n+    block (BMiddle n)  = node n+    block (BLast   n)  = node n+    block (BCat b1 b2) = block b1 `cat` block b2+    block (BHead h n)  = block h  `cat` node n+    block (BTail n t)  = node  n  `cat` block t+    block (BClosed h t)= block h  `cat` block t++    node n f+      = do { bwdres <- brewrite pass n f+           ; case bwdres of+               Nothing -> return (singletonDG entry_f n, entry_f)+                            where entry_f = btransfer pass n f+               Just (g, rw) ->+                          do { let pass' = pass { bp_rewrite = rw }+                             ; (g, f) <- arbGraph pass' (fwdEntryLabel n) g f+                             ; return (g, bwdEntryFact (bp_lattice pass) n f)} }++    -- | Compose fact transformers and concatenate the resulting+    -- rewritten graphs.+    {-# INLINE cat #-} +    cat ft1 ft2 f = do { (g2,f2) <- ft2 f+                       ; (g1,f1) <- ft1 f2+                       ; return (g1 `dgSplice` g2, f1) }++    arbx :: forall thing x .+            NonLocal thing+         => (thing C x -> Fact x f -> m (DG f n C x, f))+         -> (thing C x -> Fact x f -> m (DG f n C x, Fact C f))++    arbx arb thing f = do { (rg, f) <- arb thing f+                          ; let fb = joinInFacts (bp_lattice pass) $+                                     mapSingleton (entryLabel thing) f+                          ; return (rg, fb) }+     -- joinInFacts adds debugging information++                    -- Outgoing factbase is restricted to Labels *not* in+                    -- 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+      where+        blocks = backwardBlockList entries blockmap+        do_block :: forall x. Block n C x -> Fact x f -> m (DG f n C x, LabelMap f)+        do_block b f = do (g, f) <- block b f+                          return (g, mapSingleton (entryLabel b) f)+++backwardBlockList :: (LabelsPtr entries, NonLocal n) => entries -> Body n -> [Block n C C]+-- This produces a list of blocks in order suitable for backward analysis,+-- along with the list of Labels it may depend on for facts.+backwardBlockList entries body = reverse $ forwardBlockList entries body++{-++The forward and backward cases are not dual.  In the forward case, the+entry points are known, and one simply traverses the body blocks from+those points.  In the backward case, something is known about the exit+points, but this information is essentially useless, because we don't+actually have a dual graph (that is, one with edges reversed) to+compute with.  (Even if we did have a dual graph, it would not avail+us---a backward analysis must include reachable blocks that don't+reach the exit, as in a procedure that loops forever and has side+effects.)++-}+++-- | if the graph being analyzed is open at the exit, I don't+--   quite understand the implications of possible other exits+analyzeAndRewriteBwd+   :: (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)+analyzeAndRewriteBwd pass entries g f =+  do (rg, fout) <- arbGraph pass (fmap targetLabels entries) g f+     let (g', fb) = normalizeGraph rg+     return (g', fb, distinguishedEntryFact g' fout)++distinguishedEntryFact :: forall n e x f . Graph n e x -> Fact e f -> MaybeO e f+distinguishedEntryFact g f = maybe g+    where maybe :: Graph n e x -> MaybeO e f+          maybe GNil       = JustO f+          maybe (GUnit {}) = JustO f+          maybe (GMany e _ _) = case e of NothingO -> NothingO+                                          JustO _  -> JustO f++-----------------------------------------------------------------------------+--      fixpoint: finding fixed points+-----------------------------------------------------------------------------+-- @ start txfb.tex+data TxFactBase n f+  = TxFB { tfb_fbase :: FactBase f+         , tfb_rg    :: DG f n C C -- Transformed blocks+         , tfb_cha   :: ChangeFlag+         , tfb_lbls  :: LabelSet }+-- @ end txfb.tex+     -- See Note [TxFactBase invariants]+-- @ start update.tex+updateFact :: DataflowLattice f -> LabelSet+           -> Label -> f -> (ChangeFlag, FactBase f)+           -> (ChangeFlag, FactBase f)+-- See Note [TxFactBase change flag]+updateFact lat lbls lbl new_fact (cha, fbase)+  | NoChange <- cha2     = (cha,        fbase)+  | lbl `setMember` lbls = (SomeChange, new_fbase)+  | otherwise            = (cha,        new_fbase)+  where+    (cha2, res_fact) -- Note [Unreachable blocks]+       = case lookupFact lbl fbase of+           Nothing -> (SomeChange, new_fact_debug)  -- Note [Unreachable blocks]+           Just old_fact -> join old_fact+         where join old_fact = +                 fact_join lat lbl+                   (OldFact old_fact) (NewFact new_fact)+               (_, new_fact_debug) = join (fact_bot lat)+    new_fbase = mapInsert lbl res_fact fbase+-- @ end update.tex+++{-+-- this doesn't work because it can't be implemented+class Monad m => FixpointMonad m where+  observeChangedFactBase :: m (Maybe (FactBase f)) -> Maybe (FactBase f)+-}++-- @ start fptype.tex+data Direction = Fwd | Bwd+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))+ -> [Block n C C]+ -> (Fact C f -> m (DG f n C C, Fact C f))+-- @ end fptype.tex+-- @ start fpimp.tex+fixpoint direction lat do_block blocks init_fbase+  = do { tx_fb <- loop init_fbase+       ; return (tfb_rg tx_fb, +                 map (fst . fst) tagged_blocks +                    `mapDeleteList` tfb_fbase tx_fb ) }+    -- The successors of the Graph are the the Labels +    -- for which we have facts and which are *not* in+    -- the blocks of the graph+  where+    tagged_blocks = map tag blocks+    is_fwd = case direction of { Fwd -> True; +                                 Bwd -> False }+    tag :: NonLocal t => t C C -> ((Label, t C C), [Label])+    tag b = ((entryLabel b, b), +             if is_fwd then [entryLabel b] +                        else successors b)+     -- 'tag' adds the in-labels of the block; +     -- see Note [TxFactBase invairants]++    tx_blocks :: [((Label, Block n C C), [Label])]   -- I do not understand this type+              -> TxFactBase n f -> m (TxFactBase n f)+    tx_blocks []              tx_fb = return tx_fb+    tx_blocks (((lbl,blk), in_lbls):bs) tx_fb +      = tx_block lbl blk in_lbls tx_fb >>= tx_blocks bs+     -- "in_lbls" == Labels the block may +     --                 _depend_ upon for facts++    tx_block :: Label -> Block n C C -> [Label]+             -> TxFactBase n f -> m (TxFactBase n f)+    tx_block lbl blk in_lbls +        tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls+                    , tfb_rg = blks, tfb_cha = cha })+      | is_fwd && not (lbl `mapMember` fbase)+      = return (tx_fb {tfb_lbls = lbls'})       -- Note [Unreachable blocks]+      | otherwise+      = do { (rg, out_facts) <- do_block blk fbase+           ; let (cha', fbase') = mapFoldWithKey+                                  (updateFact lat lbls) +                                  (cha,fbase) out_facts+           ; return $+               TxFB { tfb_lbls  = lbls'+                    , tfb_rg    = rg `dgSplice` blks+                    , tfb_fbase = fbase'+                    , tfb_cha = cha' } }+      where+        lbls' = lbls `setUnion` setFromList in_lbls+        ++    loop :: FactBase f -> m (TxFactBase n f)+    loop fbase +      = do { s <- checkpoint+           ; let init_tx :: TxFactBase n f+                 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) } }+-- @ end fpimp.tex           +++{-  Note [TxFactBase invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The TxFactBase is used only during a fixpoint iteration (or "sweep"),+and accumulates facts (and the transformed code) during the fixpoint+iteration.++* tfb_fbase increases monotonically, across all sweeps++* At the beginning of each sweep+      tfb_cha  = NoChange+      tfb_lbls = {}++* During each sweep we process each block in turn.  Processing a block+  is done thus:+    1.  Read from tfb_fbase the facts for its entry label (forward)+        or successors labels (backward)+    2.  Transform those facts into new facts for its successors (forward)+        or entry label (backward)+    3.  Augment tfb_fbase with that info+  We call the labels read in step (1) the "in-labels" of the sweep++* The field tfb_lbls is the set of in-labels of all blocks that have+  been processed so far this sweep, including the block that is+  currently being processed.  tfb_lbls is initialised to {}.  It is a+  subset of the Labels of the *original* (not transformed) blocks.++* The tfb_cha field is set to SomeChange iff we decide we need to+  perform another iteration of the fixpoint loop. It is initialsed to NoChange.++  Specifically, we set tfb_cha to SomeChange in step (3) iff+    (a) The fact in tfb_fbase for a block L changes+    (b) L is in tfb_lbls+  Reason: until a label enters the in-labels its accumuated fact in tfb_fbase+  has not been read, hence cannot affect the outcome++Note [Unreachable blocks]+~~~~~~~~~~~~~~~~~~~~~~~~~+A block that is not in the domain of tfb_fbase is "currently unreachable".+A currently-unreachable block is not even analyzed.  Reason: consider +constant prop and this graph, with entry point L1:+  L1: x:=3; goto L4+  L2: x:=4; goto L4+  L4: if x>3 goto L2 else goto L5+Here L2 is actually unreachable, but if we process it with bottom input fact,+we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.++* If a currently-unreachable block is not analyzed, then its rewritten+  graph will not be accumulated in tfb_rg.  And that is good:+  unreachable blocks simply do not appear in the output.++* Note that clients must be careful to provide a fact (even if bottom)+  for each entry point. Otherwise useful blocks may be garbage collected.++* Note that updateFact must set the change-flag if a label goes from+  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the+  real fact lattice is+       UNR+       bottom+       the points above bottom++* Even if the fact is going from UNR to bottom, we still call the+  client's fact_join function because it might give the client+  some useful debugging information.++* All of this only applies for *forward* fixpoints.  For the backward+  case we must treat every block as reachable; it might finish with a+  'return', and therefore have no successors, for example.+-}++-----------------------------------------------------------------------------+--      DG: an internal data type for 'decorated graphs'+--          TOTALLY internal to Hoopl; each block is decorated with a fact+-----------------------------------------------------------------------------++-- @ start dg.tex+type Graph = Graph' Block+type DG f  = Graph' (DBlock f)+data DBlock f n e x = DBlock f (Block n e x) -- ^ block decorated with fact+-- @ end dg.tex+instance NonLocal n => NonLocal (DBlock f n) where+  entryLabel (DBlock _ b) = entryLabel b+  successors (DBlock _ b) = successors b++--- constructors++dgnil  :: DG f n O O+dgnilC :: DG f n C C+dgSplice  :: NonLocal n => DG f n e a -> DG f n a x -> DG f n e x++---- observers++type GraphWithFacts n f e x = (Graph n e x, FactBase f)+  -- A Graph together with the facts for that graph+  -- The domains of the two maps should be identical++normalizeGraph :: forall n f e x .+                  NonLocal n => DG f n e x -> GraphWithFacts n f e x++normalizeGraph g = (graphMapBlocks dropFact g, facts g)+    where dropFact :: DBlock t t1 t2 t3 -> Block t1 t2 t3+          dropFact (DBlock _ b) = b+          facts :: DG f n e x -> FactBase f+          facts GNil = noFacts+          facts (GUnit _) = noFacts+          facts (GMany _ body exit) = bodyFacts body `mapUnion` exitFacts exit+          exitFacts :: MaybeO x (DBlock f n C O) -> FactBase f+          exitFacts NothingO = noFacts+          exitFacts (JustO (DBlock f b)) = mapSingleton (entryLabel b) f+          bodyFacts :: LabelMap (DBlock f n C C) -> FactBase f+          bodyFacts body = mapFold f noFacts body+            where f :: forall t a x. (NonLocal t) => DBlock a t C x -> LabelMap a -> LabelMap a+                  f (DBlock f b) fb = mapInsert (entryLabel b) f fb++--- implementation of the constructors (boring)++dgnil  = GNil+dgnilC = GMany NothingO emptyBody NothingO++dgSplice = U.splice fzCat+  where fzCat :: DBlock f n e O -> DBlock t n O x -> DBlock f n e x+        fzCat (DBlock f b1) (DBlock _ b2) = DBlock f (b1 `U.cat` b2)++----------------------------------------------------------------+--       Utilities+----------------------------------------------------------------++-- Lifting based on shape:+--  - from nodes to blocks+--  - from facts to fact-like things+-- Lowering back:+--  - from fact-like things to facts+-- Note that the latter two functions depend only on the entry shape.+-- @ start node.tex+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+ fwdEntryLabel :: NonLocal n => n e x -> MaybeC e [Label]+ ftransfer :: FwdPass m n f -> n e x -> f -> Fact x f+ frewrite  :: FwdPass m n f -> n e x +           -> f -> m (Maybe (Graph n e x, FwdRewrite m n f))+-- @ end node.tex+ bwdEntryFact :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f+ btransfer    :: BwdPass m n f -> n e x -> Fact x f -> f+ brewrite     :: BwdPass m n f -> n e x+              -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f))++instance ShapeLifter C O where+  singletonDG f = gUnitCO . DBlock f . BFirst+  fwdEntryFact     n f  = mapSingleton (entryLabel n) f+  bwdEntryFact lat n fb = getFact lat (entryLabel n) fb+  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (ft, _, _)}) n f = ft n f+  btransfer (BwdPass {bp_transfer = BwdTransfer3 (bt, _, _)}) n f = bt n f+  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (fr, _, _)}) n f = fr n f+  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (br, _, _)}) n f = br n f+  fwdEntryLabel n = JustC [entryLabel n]++instance ShapeLifter O O where+  singletonDG f = gUnitOO . DBlock f . BMiddle+  fwdEntryFact   _ f = f+  bwdEntryFact _ _ f = f+  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, ft, _)}) n f = ft n f+  btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, bt, _)}) n f = bt n f+  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (_, fr, _)}) n f = fr n f+  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (_, br, _)}) n f = br n f+  fwdEntryLabel _ = NothingC++instance ShapeLifter O C where+  singletonDG f = gUnitOC . DBlock f . BLast+  fwdEntryFact   _ f = f+  bwdEntryFact _ _ f = f+  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, _, ft)}) n f = ft n f+  btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, _, bt)}) n f = bt n f+  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (_, _, fr)}) n f = fr n f+  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (_, _, br)}) n f = br n f+  fwdEntryLabel _ = NothingC++-- Fact lookup: the fact `orelse` bottom+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.

@@ -0,0 +1,103 @@+{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-}++module Compiler.Hoopl.Debug +  ( TraceFn , debugFwdJoins , debugBwdJoins+  , debugFwdTransfers , debugBwdTransfers+  )+where++import Compiler.Hoopl.Dataflow+import Compiler.Hoopl.Show++--------------------------------------------------------------------------------+-- | Debugging combinators:+-- Each combinator takes a dataflow pass and produces+-- a dataflow pass that can output debugging messages.+-- You provide the function, we call it with the applicable message.+-- +-- The most common use case is probably to:+--+--   1. import 'Debug.Trace'+--+--   2. pass 'trace' as the 1st argument to the debug combinator+--+--   3. pass 'const true' as the 2nd argument to the debug combinator+--+-- There are two kinds of debugging messages for a join,+-- depending on whether the join is higher in the lattice than the old fact:+--   1. If the join is higher, we show:+--         + Join@L: f1 `join` f2 = f'+--      where:+--        + indicates a change+--        L is the label where the join takes place+--        f1 is the old fact at the label+--        f2 is the new fact we are joining to f1+--        f' is the result of the join+--   2. _ Join@L: f2 <= f1+--      where:+--        _ indicates no change+--        L is the label where the join takes place+--        f1 is the old fact at the label (which remains unchanged)+--        f2 is the new fact we joined with f1+--------------------------------------------------------------------------------+++debugFwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> FwdPass m n f -> FwdPass m n f+debugBwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> BwdPass m n f -> BwdPass m n f++type TraceFn    = forall a . String -> a -> a+type ChangePred = ChangeFlag -> Bool++debugFwdJoins trace pred p = p { fp_lattice = debugJoins trace pred $ fp_lattice p }+debugBwdJoins trace pred p = p { bp_lattice = debugJoins trace pred $ bp_lattice p }++debugJoins :: Show f => TraceFn -> ChangePred -> DataflowLattice f -> DataflowLattice f+debugJoins trace showPred l@(DataflowLattice {fact_join = join}) = l {fact_join = join'}+  where+   join' l f1@(OldFact of1) f2@(NewFact nf2) =+     if showPred c then trace output res else res+       where res@(c, f') = join l f1 f2+             output = case c of+                        SomeChange -> "+ Join@" ++ show l ++ ": " ++ show of1 ++ " `join` "+                                                                  ++ show nf2 ++ " = " ++ show f'+                        NoChange   -> "_ Join@" ++ show l ++ ": " ++ show nf2 ++ " <= " ++ show of1++--------------------------------------------------------------------------------+-- Functions we'd like to have, but don't know how to implement generically:+--------------------------------------------------------------------------------++type ShowN n   = forall e x . n e x ->      String+type FPred n f = forall e x . n e x -> f        -> Bool+type BPred n f = forall e x . n e x -> Fact x f -> Bool+debugFwdTransfers::+  forall m n f . Show f => TraceFn -> ShowN n -> FPred n f -> FwdPass m n f -> FwdPass m n f+debugFwdTransfers trace showN showPred pass = pass { fp_transfer = transfers' }+  where+    (f, m, l) = getFTransfer3 $ fp_transfer pass+    transfers' = mkFTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l)+    wrap :: forall e x . (Fact x f -> String) -> (n e x -> f -> Fact x f) -> n e x -> f -> Fact x f+    wrap showOutF ft n f = if showPred n f then trace output res else res+      where+        res    = ft n f+        output = name ++ " transfer: " ++ show f ++ " -> " ++ showN n ++ " -> " ++ showOutF res+    name = fact_name (fp_lattice pass)+    +debugBwdTransfers::+  forall m n f . Show f => TraceFn -> ShowN n -> BPred n f -> BwdPass m n f -> BwdPass m n f+debugBwdTransfers trace showN showPred pass = pass { bp_transfer = transfers' }+  where+    (f, m, l) = getBTransfer3 $ bp_transfer pass+    transfers' = mkBTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l)+    wrap :: forall e x . (Fact x f -> String) -> (n e x -> Fact x f -> f) -> n e x -> Fact x f -> f+    wrap showInF ft n f = if showPred n f then trace output res else res+      where+        res    = ft n f+        output = name ++ " transfer: " ++ showInF f ++ " -> " ++ showN n ++ " -> " ++ show res+    name = fact_name (bp_lattice pass)+    ++-- debugFwdTransfers, debugFwdRewrites, debugFwdAll ::+--   forall m n f . Show f => TraceFn -> ShowN n -> FwdPass m n f -> FwdPass m n f+-- debugBwdTransfers, debugBwdRewrites, debugBwdAll ::+--   forall m n f . Show f => TraceFn -> ShowN n -> BwdPass m n f -> BwdPass m n f+

@@ -0,0 +1,105 @@+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+--		The fuel monad+-----------------------------------------------------------------------------++module Compiler.Hoopl.Fuel+  ( Fuel, infiniteFuel, fuelRemaining+  , withFuel+  , FuelMonad(..)+  , FuelMonadT(..)+  , CheckingFuelMonad+  , InfiniteFuelMonad+  , SimpleFuelMonad+  )+where++import Compiler.Hoopl.Checkpoint+import Compiler.Hoopl.Unique++class Monad m => FuelMonad m where+  getFuel :: m Fuel+  setFuel :: Fuel -> m ()++-- | 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++class FuelMonadT fm where+  runWithFuel :: (Monad m, FuelMonad (fm m)) => Fuel -> fm m a -> m a+++type Fuel = Int++withFuel :: FuelMonad m => Maybe a -> m (Maybe a)+withFuel Nothing  = return Nothing+withFuel (Just a) = do f <- getFuel+                       if f == 0+                         then return Nothing+                         else setFuel (f-1) >> return (Just a)+++----------------------------------------------------------------++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' })++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) })++instance Monad m => FuelMonad (CheckingFuelMonad m) where+  getFuel   = FM (\f -> return (f, f))+  setFuel f = FM (\_ -> return ((),f))++instance FuelMonadT CheckingFuelMonad where+  runWithFuel fuel m = do { (a, _) <- unFM m fuel; return a }++----------------------------------------------------------------++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 UniqueMonad m => UniqueMonad (InfiniteFuelMonad m) where+  freshUnique = IFM $ freshUnique++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++infiniteFuel :: Fuel -- effectively infinite, any, but subtractable+infiniteFuel = maxBound++type SimpleFuelMonad = CheckingFuelMonad SimpleUniqueMonad++{-+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))+-}+

@@ -0,0 +1,24 @@+{-# LANGUAGE GADTs, RankNTypes #-}++{- Exposing some internals to GHC -}+module Compiler.Hoopl.GHC+  ( uniqueToInt+  , uniqueToLbl, lblToUnique+  , getFuel, setFuel+  , bodyToBlockMap, bodyOfBlockMap+  )+where++import Compiler.Hoopl.Fuel+import Compiler.Hoopl.Graph+import Compiler.Hoopl.Label+import Compiler.Hoopl.Unique++-- Converts Body to a map of closed/closed blocks.+-- It should better be a constant-time operation+-- as GHC is counting on it.+bodyToBlockMap :: Body' block n -> LabelMap (block n C C)+bodyToBlockMap (Body bodyMap) = bodyMap++bodyOfBlockMap :: LabelMap (block n C C) -> Body' block n+bodyOfBlockMap = Body

@@ -0,0 +1,119 @@+{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies #-}++module Compiler.Hoopl.Graph +  ( O, C, Block(..), Body, Body'(..), Graph, Graph'(..)+  , MaybeO(..), MaybeC(..), Shape(..), IndexedCO+  , NonLocal(entryLabel, successors)+  , emptyBody, addBlock, bodyList+  )+where++import Compiler.Hoopl.Collections+import Compiler.Hoopl.Label++-----------------------------------------------------------------------------+--		Graphs+-----------------------------------------------------------------------------++-- | Used at the type level to indicate an "open" structure with    +-- a unique, unnamed control-flow edge flowing in or out.         +-- "Fallthrough" and concatenation are permitted at an open point.+data O +       +       +-- | Used at the type level to indicate a "closed" structure which+-- supports control transfer only through the use of named+-- labels---no "fallthrough" is permitted.  The number of control-flow+-- edges is unconstrained.+data C++-- | A sequence of nodes.  May be any of four shapes (O/O, O/C, C/O, C/C).+-- Open at the entry means single entry, mutatis mutandis for exit.+-- A closed/closed block is a /basic/ block and can't be extended further.+-- Clients should avoid manipulating blocks and should stick to either nodes+-- or graphs.+data Block n e x where+  -- nodes+  BFirst  :: n C O                 -> Block n C O -- x^ block holds a single first node+  BMiddle :: n O O                 -> Block n O O -- x^ block holds a single middle node+  BLast   :: n O C                 -> Block n O C -- x^ block holds a single last node++  -- concatenation operations+  BCat    :: Block n O O -> Block n O O -> Block n O O -- non-list-like+  BHead   :: Block n C O -> n O O       -> Block n C O+  BTail   :: n O O       -> Block n O C -> Block n O C  ++  BClosed :: Block n C O -> Block n O C -> Block n C C -- the zipper++-- | A (possibly empty) collection of closed/closed blocks+type Body n = LabelMap (Block n C C)+newtype Body' block n = Body (LabelMap (block n C C))++-- | A control-flow graph, which may take any of four shapes (O/O, O/C, C/O, C/C).+-- A graph open at the entry has a single, distinguished, anonymous entry point;+-- if a graph is closed at the entry, its entry point(s) are supplied by a context.+type Graph = Graph' Block+data Graph' block n e x where+  GNil  :: Graph' block n O O+  GUnit :: block n O O -> Graph' block n O O+  GMany :: MaybeO e (block n O C) +        -> LabelMap (block n C C)+        -> MaybeO x (block n C O)+        -> Graph' block n e x++-- | Maybe type indexed by open/closed+data MaybeO ex t where+  JustO    :: t -> MaybeO O t+  NothingO ::      MaybeO C t++-- | Maybe type indexed by closed/open+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 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+  fmap f (JustO a) = JustO (f a)++instance Functor (MaybeC ex) where+  fmap _ NothingC = NothingC+  fmap f (JustC a) = JustC (f a)++-------------------------------+-- | Gives access to the anchor points for+-- nonlocal edges as well as the edges themselves+class NonLocal thing where +  entryLabel :: thing C x -> Label   -- ^ The label of a first node or block+  successors :: thing e C -> [Label] -- ^ Gives control-flow successors++instance NonLocal n => NonLocal (Block n) where+  entryLabel (BFirst n)    = entryLabel n+  entryLabel (BHead h _)   = entryLabel h+  entryLabel (BClosed h _) = entryLabel h+  successors (BLast n)     = successors n+  successors (BTail _ t)   = successors t+  successors (BClosed _ t) = successors t++------------------------------+emptyBody :: LabelMap (thing C C)+emptyBody = mapEmpty++addBlock :: NonLocal thing => thing C C -> LabelMap (thing C C) -> LabelMap (thing C C)+addBlock b body = nodupsInsert (entryLabel b) b body+  where nodupsInsert l b body = if mapMember l body then+                                    error $ "duplicate label " ++ show l ++ " in graph"+                                else+                                    mapInsert l b body++bodyList :: NonLocal (block n) => Body' block n -> [(Label,block n C C)]+bodyList (Body body) = mapToList body

@@ -0,0 +1,124 @@+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}++-- N.B. addBasicBlocks won't work on OO without a Node (branch/label) constraint++module Compiler.Hoopl.GraphUtil+  ( splice, gSplice , cat , bodyGraph, bodyUnion+  , frontBiasBlock, backBiasBlock+  )++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++splice :: forall block n e a x . NonLocal (block n) =>+          (forall e x . block n e O -> block n O x -> block n e x)+       -> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x)+splice bcat = sp+  where sp :: forall e a x .+              Graph' block n e a -> Graph' block n a x -> Graph' block n e x++        sp GNil g2 = g2+        sp g1 GNil = g1++        sp (GUnit b1) (GUnit b2) = GUnit (b1 `bcat` b2)++        sp (GUnit b) (GMany (JustO e) bs x) = GMany (JustO (b `bcat` e)) bs x++        sp (GMany e bs (JustO x)) (GUnit b2) = GMany e bs (JustO (x `bcat` b2))++        sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2)+          = GMany e1 (b1 `bodyUnion` b2) x2+          where b1 = addBlock (x1 `bcat` e2) bs1++        sp (GMany e1 b1 NothingO) (GMany NothingO b2 x2)+          = GMany e1 (b1 `bodyUnion` b2) x2++        sp _ _ = error "bogus GADT match failure"++bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a+bodyUnion = mapUnionWithKey nodups+  where nodups l _ _ = error $ "duplicate blocks with label " ++ show l++gSplice :: NonLocal n => Graph n e a -> Graph n a x -> Graph n e x+gSplice = splice cat++cat :: Block n e O -> Block n O x -> Block n e x+cat b1@(BFirst {})     (BMiddle n)  = BHead   b1 n+cat b1@(BFirst {})  b2@(BLast{})    = BClosed b1 b2+cat b1@(BFirst {})  b2@(BTail{})    = BClosed b1 b2+cat b1@(BFirst {})     (BCat b2 b3) = (b1 `cat` b2) `cat` b3+cat b1@(BHead {})      (BCat b2 b3) = (b1 `cat` b2) `cat` b3+cat b1@(BHead {})      (BMiddle n)  = BHead   b1 n+cat b1@(BHead {})   b2@(BLast{})    = BClosed b1 b2+cat b1@(BHead {})   b2@(BTail{})    = BClosed b1 b2+cat b1@(BMiddle {}) b2@(BMiddle{})  = BCat    b1 b2+cat    (BMiddle n)  b2@(BLast{})    = BTail    n b2+cat b1@(BMiddle {}) b2@(BCat{})     = BCat    b1 b2+cat    (BMiddle n)  b2@(BTail{})    = BTail    n b2+cat    (BCat b1 b2) b3@(BLast{})    = b1 `cat` (b2 `cat` b3)+cat    (BCat b1 b2) b3@(BTail{})    = b1 `cat` (b2 `cat` b3)+cat b1@(BCat {})    b2@(BCat{})     = BCat    b1 b2+cat b1@(BCat {})    b2@(BMiddle{})  = BCat    b1 b2+++----------------------------------------------------------------++-- | A block is "front biased" if the left child of every+-- concatenation operation is a node, not a general block; a+-- front-biased block is analogous to an ordinary list.  If a block is+-- front-biased, then its nodes can be traversed from front to back+-- without general recusion; tail recursion suffices.  Not all shapes+-- can be front-biased; a closed/open block is inherently back-biased.++frontBiasBlock :: Block n e x -> Block n e x+frontBiasBlock b@(BFirst  {}) = b+frontBiasBlock b@(BMiddle {}) = b+frontBiasBlock b@(BLast   {}) = b+frontBiasBlock b@(BCat {}) = rotate b+  where -- rotate and append ensure every left child of ZCat is ZMiddle+        -- provided 2nd argument to append already has this property+    rotate :: Block n O O -> Block n O O+    append :: Block n O O -> Block n O O -> Block n O O+    rotate (BCat h t)     = append h (rotate t)+    rotate b@(BMiddle {}) = b+    append b@(BMiddle {}) t = b `BCat` t+    append (BCat b1 b2) b3 = b1 `append` (b2 `append` b3)+frontBiasBlock b@(BHead {})    = b -- back-biased by nature; cannot fix+frontBiasBlock b@(BTail {})    = b -- statically front-biased+frontBiasBlock   (BClosed h t) = shiftRight h t+    where shiftRight :: Block n C O -> Block n O C -> Block n C C+          shiftRight (BHead b1 b2)  b3 = shiftRight b1 (BTail b2 b3)+          shiftRight b1@(BFirst {}) b2 = BClosed b1 b2++-- | A block is "back biased" if the right child of every+-- concatenation operation is a node, not a general block; a+-- back-biased block is analogous to a snoc-list.  If a block is+-- back-biased, then its nodes can be traversed from back to back+-- without general recusion; tail recursion suffices.  Not all shapes+-- can be back-biased; an open/closed block is inherently front-biased.++backBiasBlock :: Block n e x -> Block n e x+backBiasBlock b@(BFirst  {}) = b+backBiasBlock b@(BMiddle {}) = b+backBiasBlock b@(BLast   {}) = b+backBiasBlock b@(BCat {}) = rotate b+  where -- rotate and append ensure every right child of Cat is Middle+        -- provided 1st argument to append already has this property+    rotate :: Block n O O -> Block n O O+    append :: Block n O O -> Block n O O -> Block n O O+    rotate (BCat h t)     = append (rotate h) t+    rotate b@(BMiddle {}) = b+    append h b@(BMiddle {}) = h `BCat` b+    append b1 (BCat b2 b3) = (b1 `append` b2) `append` b3+backBiasBlock b@(BHead {}) = b -- statically back-biased+backBiasBlock b@(BTail {}) = b -- front-biased by nature; cannot fix+backBiasBlock (BClosed h t) = shiftLeft h t+    where shiftLeft :: Block n C O -> Block n O C -> Block n C C+          shiftLeft b1 (BTail b2 b3) = shiftLeft (BHead b1 b2) b3+          shiftLeft b1 b2@(BLast {}) = BClosed b1 b2

@@ -0,0 +1,104 @@+{-# LANGUAGE TypeFamilies #-}+module Compiler.Hoopl.Label+  ( Label+  , freshLabel+  , LabelSet, LabelMap+  , FactBase, noFacts, lookupFact++  , uniqueToLbl -- MkGraph and GHC use only+  , lblToUnique -- GHC use only+  )++where++import Compiler.Hoopl.Collections+import Compiler.Hoopl.Unique++-----------------------------------------------------------------------------+--		Label+-----------------------------------------------------------------------------++newtype Label = Label { lblToUnique :: Unique }+  deriving (Eq, Ord)++uniqueToLbl :: Unique -> Label+uniqueToLbl = Label++instance Show Label where+  show (Label n) = "L" ++ show n++freshLabel :: UniqueMonad m => m Label+freshLabel = freshUnique >>= return . uniqueToLbl++-----------------------------------------------------------------------------+-- LabelSet++newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show)++instance IsSet LabelSet where+  type ElemOf LabelSet = Label++  setNull (LS s) = setNull s+  setSize (LS s) = setSize s+  setMember (Label k) (LS s) = setMember k s++  setEmpty = LS setEmpty+  setSingleton (Label k) = LS (setSingleton k)+  setInsert (Label k) (LS s) = LS (setInsert k s)+  setDelete (Label k) (LS s) = LS (setDelete k s)++  setUnion (LS x) (LS y) = LS (setUnion x y)+  setDifference (LS x) (LS y) = LS (setDifference x y)+  setIntersection (LS x) (LS y) = LS (setIntersection x y)+  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y++  setFold k z (LS s) = setFold (k . uniqueToLbl) z s++  setElems (LS s) = map uniqueToLbl (setElems s)+  setFromList ks = LS (setFromList (map lblToUnique ks))++-----------------------------------------------------------------------------+-- LabelMap++newtype LabelMap v = LM (UniqueMap v) deriving (Eq, Ord, Show)++instance IsMap LabelMap where+  type KeyOf LabelMap = Label++  mapNull (LM m) = mapNull m+  mapSize (LM m) = mapSize m+  mapMember (Label k) (LM m) = mapMember k m+  mapLookup (Label k) (LM m) = mapLookup k m+  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m++  mapEmpty = LM mapEmpty+  mapSingleton (Label k) v = LM (mapSingleton k v)+  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)+  mapDelete (Label k) (LM m) = LM (mapDelete k m)++  mapUnion (LM x) (LM y) = LM (mapUnion x y)+  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y)+  mapDifference (LM x) (LM y) = LM (mapDifference x y)+  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)+  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y++  mapMap f (LM m) = LM (mapMap f m)+  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m)+  mapFold k z (LM m) = mapFold k z m+  mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m++  mapElems (LM m) = mapElems m+  mapKeys (LM m) = map uniqueToLbl (mapKeys m)+  mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m]+  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])++-----------------------------------------------------------------------------+-- FactBase++type FactBase f = LabelMap f++noFacts :: FactBase f+noFacts = mapEmpty++lookupFact :: Label -> FactBase f -> Maybe f+lookupFact = mapLookup

@@ -0,0 +1,252 @@+{-# LANGUAGE ScopedTypeVariables, GADTs, TypeSynonymInstances, FlexibleInstances, RankNTypes #-}+module Compiler.Hoopl.MkGraph+    ( AGraph, graphOfAGraph, aGraphOfGraph+    , (<*>), (|*><*|), catGraphs, addEntrySeq, addExitSeq, addBlocks, unionBlocks+    , emptyGraph, emptyClosedGraph, withFresh+    , mkFirst, mkMiddle, mkMiddles, mkLast, mkBranch, mkLabel, mkWhileDo+    , IfThenElseable(mkIfThenElse)+    , mkEntry, mkExit+    , HooplNode(mkLabelNode, mkBranchNode)+    )+where++import Compiler.Hoopl.Label (Label, uniqueToLbl)+import Compiler.Hoopl.Graph+import qualified Compiler.Hoopl.GraphUtil as U+import Compiler.Hoopl.Unique+import Control.Monad (liftM2)++{-|+As noted in the paper, we can define a single, polymorphic type of +splicing operation with the very polymorphic type+@+  AGraph n e a -> AGraph n a x -> AGraph n e x+@+However, we feel that this operation is a bit /too/ polymorphic,+and that it's too easy for clients to use it blindly without +thinking.  We therfore split it into two operations, '<*>' and '|*><*|', +which are supplemented by other functions:++  * The '<*>' operator is true concatenation, for connecting open graphs.+    Control flows from the left graph to the right graph.++  * The '|*><*|' operator splices together two graphs at a closed+    point. Nothing is known about control flow. The vertical bar+    stands for "closed point" just as the angle brackets above stand+    for "open point".  Unlike the <*> operator, the |*><*| can create+    a control-flow graph with dangling outedges or unreachable blocks.+    The operator must be used carefully, so we have chosen a long name+    on purpose, to help call people's attention to what they're doing.++  * The operator 'addBlocks' adds a set of basic blocks (represented+    as a closed/closed 'AGraph' to an existing graph, without changing+    the shape of the existing graph.  In some cases, it's necessary to+    introduce a branch and a label to 'get around' the blocks added,+    so this operator, and other functions based on it, requires a+    'HooplNode' type-class constraint and is available only on AGraph,+    not Graph.++  * We have discussed a dynamic assertion about dangling outedges and+    unreachable blocks, but nothing is implemented yet.++-}++++class GraphRep g where+  -- | An empty graph that is open at entry and exit.  +  -- It is the left and right identity of '<*>'.+  emptyGraph       :: g n O O+  -- | An empty graph that is closed at entry and exit.  +  -- It is the left and right identity of '|*><*|'.+  emptyClosedGraph :: g n C C+  -- | Create a graph from a first node+  mkFirst  :: n C O -> g n C O+  -- | Create a graph from a middle node+  mkMiddle :: n O O -> g n O O+  -- | Create a graph from a last node+  mkLast   :: n O C -> g n O C+  mkFirst = mkExit  . BFirst+  mkLast  = mkEntry . BLast+  infixl 3 <*>+  infixl 2 |*><*| +  -- | Concatenate two graphs; control flows from left to right.+  (<*>)    :: NonLocal n => g n e O -> g n O x -> g n e x+  -- | Splice together two graphs at a closed point; nothing is known+  -- about control flow.+  (|*><*|) :: NonLocal n => g n e C -> g n C x -> g n e x+  -- | Conveniently concatenate a sequence of open/open graphs using '<*>'.+  catGraphs :: NonLocal n => [g n O O] -> g n O O+  catGraphs = foldr (<*>) emptyGraph++  -- | Create a graph that defines a label+  mkLabel  :: HooplNode n => Label -> g n C O -- definition of the label+  -- | Create a graph that branches to a label+  mkBranch :: HooplNode n => Label -> g n O C -- unconditional branch to the label++  -- | Conveniently concatenate a sequence of middle nodes to form+  -- an open/open graph.+  mkMiddles :: NonLocal n => [n O O] -> g n O O++  mkLabel  id     = mkFirst $ mkLabelNode id+  mkBranch target = mkLast  $ mkBranchNode target+  mkMiddles ms    = catGraphs $ map mkMiddle ms++  -- | Create a graph containing only an entry sequence+  mkEntry   :: Block n O C -> g n O C+  -- | Create a graph containing only an exit sequence+  mkExit    :: Block n C O -> g n C O++instance GraphRep Graph where+  emptyGraph  = GNil+  emptyClosedGraph = GMany NothingO emptyBody NothingO+  (<*>)       = U.gSplice+  (|*><*|)    = U.gSplice+  mkMiddle    = GUnit . BMiddle+  mkExit   block = GMany NothingO      emptyBody (JustO block)+  mkEntry  block = GMany (JustO block) emptyBody NothingO++instance GraphRep AGraph where+  emptyGraph  = aGraphOfGraph emptyGraph+  emptyClosedGraph = aGraphOfGraph emptyClosedGraph+  (<*>)       = liftA2 (<*>)+  (|*><*|)    = liftA2 (|*><*|)+  mkMiddle    = aGraphOfGraph . mkMiddle+  mkExit  = aGraphOfGraph . mkExit+  mkEntry = aGraphOfGraph . mkEntry+++-- | The type of abstract graphs.  Offers extra "smart constructors"+-- that may consume fresh labels during construction.+newtype AGraph n e x =+  A { graphOfAGraph :: forall m. UniqueMonad m =>+                       m (Graph n e x) -- ^ Take an abstract 'AGraph'+                                       -- and make a concrete (if monadic)+                                       -- 'Graph'.+    }++-- | Take a graph and make it abstract.+aGraphOfGraph :: Graph n e x -> AGraph n e x+aGraphOfGraph g = A (return g)+++-- | The 'Labels' class defines things that can be lambda-bound+-- by an argument to 'withFreshLabels'.  Such an argument may+-- lambda-bind a single 'Label', or if multiple labels are needed,+-- it can bind a tuple.  Tuples can be nested, so arbitrarily many+-- fresh labels can be acquired in a single call.+-- +-- For example usage see implementations of 'mkIfThenElse' and 'mkWhileDo'.+class Uniques u where+  withFresh :: (u -> AGraph n e x) -> AGraph n e x++instance Uniques Unique where+  withFresh f = A $ freshUnique >>= (graphOfAGraph . f)++instance Uniques Label where+  withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl)++-- | 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 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 (A g) (A blocks) = A $ g >>= \g -> blocks >>= add g+  where add :: (UniqueMonad 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 `U.bodyUnion` body') x+        add g@GNil      blocks = spliceOO g blocks+        add g@(GUnit _) blocks = spliceOO g blocks+        spliceOO :: (HooplNode n, UniqueMonad m)+                 => Graph n O O -> Graph n C C -> m (Graph n O O)+        spliceOO g blocks = graphOfAGraph $ withFresh $ \l ->+          A (return g) <*> mkBranch l |*><*| A (return blocks) |*><*| mkLabel l++-- | For some graph-construction operations and some optimizations,+-- Hoopl must be able to create control-flow edges using a given node+-- type 'n'.+class NonLocal n => HooplNode n where+  -- | Create a branch node, the source of a control-flow edge.+  mkBranchNode :: Label -> n O C+  -- | Create a label node, the target (destination) of a control-flow edge.+  mkLabelNode  :: Label -> n C O++--------------------------------------------------------------+--                   Shiny Things+--------------------------------------------------------------++class IfThenElseable x where+  -- | Translate a high-level if-then-else construct into an 'AGraph'.+  -- 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++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++instance IfThenElseable O where+  mkIfThenElse cbranch tbranch fbranch = withFresh $ \(endif, ltrue, lfalse) ->+    cbranch ltrue lfalse |*><*|+      mkLabel ltrue  <*> tbranch <*> mkBranch endif |*><*|+      mkLabel lfalse <*> fbranch <*> mkBranch endif |*><*|+      mkLabel endif++instance IfThenElseable C where+  mkIfThenElse cbranch tbranch fbranch = withFresh $ \(ltrue, lfalse) ->+    cbranch ltrue lfalse |*><*|+       mkLabel ltrue  <*> tbranch |*><*|+       mkLabel lfalse <*> fbranch++mkWhileDo cbranch body = withFresh $ \(test, head, endwhile) ->+     -- Forrest Baskett's while-loop layout+  mkBranch test |*><*|+    mkLabel head <*> body <*> mkBranch test |*><*|+    mkLabel test <*> cbranch head endwhile  |*><*|+    mkLabel endwhile++--------------------------------------------------------------+--               Boring instance declarations+--------------------------------------------------------------+++instance (Uniques u1, Uniques u2) => Uniques (u1, u2) where+  withFresh f = withFresh $ \u1 ->+                withFresh $ \u2 ->+                f (u1, u2)++instance (Uniques u1, Uniques u2, Uniques u3) => Uniques (u1, u2, u3) where+  withFresh f = withFresh $ \u1 ->+                withFresh $ \u2 ->+                withFresh $ \u3 ->+                f (u1, u2, u3)++instance (Uniques u1, Uniques u2, Uniques u3, Uniques u4) => Uniques (u1, u2, u3, u4) where+  withFresh f = withFresh $ \u1 ->+                withFresh $ \u2 ->+                withFresh $ \u3 ->+                withFresh $ \u4 ->+                f (u1, u2, u3, u4)++---------------------------------------------+-- deprecated legacy functions++{-# DEPRECATED addEntrySeq, addExitSeq, unionBlocks "use |*><*| instead" #-}+addEntrySeq :: NonLocal n => AGraph n O C -> AGraph n C x -> AGraph n O x+addExitSeq  :: NonLocal n => AGraph n e C -> AGraph n C O -> AGraph n e O+unionBlocks :: NonLocal n => AGraph n C C -> AGraph n C C -> AGraph n C C++addEntrySeq = (|*><*|)+addExitSeq  = (|*><*|)+unionBlocks = (|*><*|)

@@ -0,0 +1,45 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}++module Compiler.Hoopl.Passes.DList+  ( Doms, domEntry, domLattice+  , domPass+  )+where++import Compiler.Hoopl+++type Doms = WithBot [Label]+-- ^ List of labels, extended with a standard bottom element++-- | The fact that goes into the entry of a dominator analysis: the first node+-- is dominated only by the entry point, which is represented by the empty list+-- of labels.+domEntry :: Doms+domEntry = PElem []++domLattice :: DataflowLattice Doms+domLattice = addPoints "dominators" extend++extend :: JoinFun [Label]+extend _ (OldFact l) (NewFact l') = (changeIf (l `lengthDiffers` j), j)+    where j = lcs l l'+          lcs :: [Label] -> [Label] -> [Label] -- longest common suffix+          lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l'+                   | length l < length l' = lcs l' l+                   | otherwise = dropUnlike l l' l+          dropUnlike [] [] maybe_like = maybe_like+          dropUnlike (x:xs) (y:ys) maybe_like =+              dropUnlike xs ys (if x == y then maybe_like else xs)+          dropUnlike _ _ _ = error "this can't happen"++          lengthDiffers [] [] = False+          lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys+          lengthDiffers [] (_:_) = True+          lengthDiffers (_:_) [] = True++-- | Dominator pass+domPass :: (NonLocal n, Monad m) => FwdPass m n Doms+domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite+  where first n = fmap (entryLabel n:)

@@ -0,0 +1,130 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}++module Compiler.Hoopl.Passes.Dominator+  ( Doms, DPath(..), domPath, domEntry, domLattice, extendDom+  , DominatorNode(..), DominatorTree(..), tree+  , immediateDominators+  , domPass+  )+where++import Data.Maybe++import Compiler.Hoopl+++type Doms = WithBot DPath+-- ^ List of labels, extended with a standard bottom element++-- | The fact that goes into the entry of a dominator analysis: the first node+-- is dominated only by the entry point, which is represented by the empty list+-- of labels.+domEntry :: Doms+domEntry = PElem (DPath [])++newtype DPath = DPath [Label]+  -- ^ represents part of the domination relation: each label+  -- in a list is dominated by all its successors.  This is a newtype only so+  -- we can give it a fancy Show instance.++instance Show DPath where+  show (DPath ls) = concat (foldr (\l path -> show l : " -> " : path) ["entry"] ls)++domPath :: Doms -> [Label]+domPath Bot = [] -- lies: an unreachable node appears to be dominated by the entry+domPath (PElem (DPath ls)) = ls++extendDom :: Label -> DPath -> DPath+extendDom l (DPath ls) = DPath (l:ls)++domLattice :: DataflowLattice Doms+domLattice = addPoints "dominators" extend++extend :: JoinFun DPath+extend _ (OldFact (DPath l)) (NewFact (DPath l')) =+                                (changeIf (l `lengthDiffers` j), DPath j)+    where j = lcs l l'+          lcs :: [Label] -> [Label] -> [Label] -- longest common suffix+          lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l'+                   | length l < length l' = lcs l' l+                   | otherwise = dropUnlike l l' l+          dropUnlike [] [] maybe_like = maybe_like+          dropUnlike (x:xs) (y:ys) maybe_like =+              dropUnlike xs ys (if x == y then maybe_like else xs)+          dropUnlike _ _ _ = error "this can't happen"++          lengthDiffers [] [] = False+          lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys+          lengthDiffers [] (_:_) = True+          lengthDiffers (_:_) [] = True++++-- | Dominator pass+domPass :: (NonLocal n, Monad m) => FwdPass m n Doms+domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite+  where first n = fmap (extendDom $ entryLabel n)++----------------------------------------------------------------++data DominatorNode = Entry | Labelled Label+data DominatorTree = Dominates DominatorNode [DominatorTree]+-- ^ This data structure is a *rose tree* in which each node may have+--  arbitrarily many children.  Each node dominates all its descendants.++-- | Map from a FactBase for dominator lists into a+-- dominator tree.  +tree :: [(Label, Doms)] -> DominatorTree+tree facts = Dominates Entry $ merge $ map reverse $ map mkList facts+   -- This code has been lightly tested.  The key insight is this: to+   -- find lists that all have the same head, convert from a list of+   -- lists to a finite map, in 'children'.  Then, to convert from the+   -- finite map to list of dominator trees, use the invariant that+   -- each key dominates all the lists of values.+  where merge lists = mapTree $ children $ filter (not . null) lists+        children = foldl addList noFacts+        addList :: FactBase [[Label]] -> [Label] -> FactBase [[Label]]+        addList map (x:xs) = mapInsert 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) <- mapToList map]+        mkList (l, doms) = l : domPath doms+++instance Show DominatorTree where+  show = tree2dot++-- | Given a dominator tree, produce a string representation, in the+-- input language of dot, that will enable dot to produce a+-- visualization of the tree.  For more info about dot see+-- http://www.graphviz.org.++tree2dot :: DominatorTree -> String+tree2dot t = concat $ "digraph {\n" : dot t ["}\n"]+  where+    dot :: DominatorTree -> [String] -> [String]+    dot (Dominates root trees) = +                   (dotnode root :) . outedges trees . flip (foldl subtree) trees+      where outedges [] = id+            outedges (Dominates n _ : ts) =+                \s -> "  " : show root : " -> " : show n : "\n" : outedges ts s+            dotnode Entry = "  entryNode [shape=plaintext, label=\"entry\"]\n"+            dotnode (Labelled l) = "  " ++ show l ++ "\n"+            subtree = flip dot++instance Show DominatorNode where+  show Entry = "entryNode"+  show (Labelled l) = show l++----------------------------------------------------------------++-- | Takes FactBase from dominator analysis and returns a map from each +-- label to its immediate dominator, if any+immediateDominators :: FactBase Doms -> LabelMap Label+immediateDominators = mapFoldWithKey add mapEmpty+    where add l (PElem (DPath (idom:_))) = mapInsert l idom +          add _ _ = id+

@@ -0,0 +1,147 @@+{-# LANGUAGE GADTs, ScopedTypeVariables #-}++-- | Possibly doubly pointed lattices++module Compiler.Hoopl.Pointed+  ( Pointed(..), addPoints, addPoints', addTop, addTop'+  , liftJoinTop, extendJoinDomain+  , WithTop, WithBot, WithTopAndBot+  )+where++import Compiler.Hoopl.Graph+import Compiler.Hoopl.Label+import Compiler.Hoopl.Dataflow++-- | Adds top, bottom, or both to help form a lattice+data Pointed t b a where+   Bot   ::      Pointed t C a+   PElem :: a -> Pointed t b a+   Top   ::      Pointed C b a++-- ^ The type parameters 't' and 'b' are used to say whether top+-- and bottom elements have been added.  The analogy with 'Block'+-- is nearly exact:+--+--  * A 'Block' is closed at the entry if and only if it has a first node;+--    a 'Pointed' is closed at the top if and only if it has a top element.+--+--  * A 'Block' is closed at the exit if and only if it has a last node;+--    a 'Pointed' is closed at the bottom if and only if it has a bottom element.+--+-- We thus have four possible types, of which three are interesting:+--+--  [@Pointed C C a@] Type @a@ extended with both top and bottom elements.+--+--  [@Pointed C O a@] Type @a@ extended with a top element+--  only. (Presumably @a@ comes equipped with a bottom element of its own.)+--+--  [@Pointed O C a@] Type @a@ extended with a bottom element only. +--+--  [@Pointed O O a@] Isomorphic to @a@, and therefore not interesting.+--+-- The advantage of all this GADT-ishness is that the constructors+-- 'Bot', 'Top', and 'PElem' can all be used polymorphically.+--+-- A 'Pointed t b' type is an instance of 'Functor' and 'Show'.++++type WithBot a = Pointed O C a+-- ^ Type 'a' with a bottom element adjoined++type WithTop a = Pointed C O a+-- ^ Type 'a' with a top element adjoined++type WithTopAndBot a = Pointed C C a+-- ^ Type 'a' with top and bottom elements adjoined+++-- | Given a join function and a name, creates a semi lattice by+-- adding a bottom element, and possibly a top element also.+-- A specialized version of 'addPoints''.+addPoints  :: String -> JoinFun a -> DataflowLattice (Pointed t C a)+-- | A more general case for creating a new lattice+addPoints' :: forall a t .+              String+           -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, Pointed t C a))+           -> DataflowLattice (Pointed t C a)++addPoints name join = addPoints' name join'+   where join' l o n = (change, PElem f)+            where (change, f) = join l o n++addPoints' name joinx = DataflowLattice name Bot join+  where -- careful: order of cases matters for ChangeFlag+        join :: JoinFun (Pointed t C a)+        join _ (OldFact f)            (NewFact Bot) = (NoChange, f)+        join _ (OldFact Top)          (NewFact _)   = (NoChange, Top)+        join _ (OldFact Bot)          (NewFact f)   = (SomeChange, f)+        join _ (OldFact _)            (NewFact Top) = (SomeChange, Top)+        join l (OldFact (PElem old)) (NewFact (PElem new))+           = joinx l (OldFact old) (NewFact new)+++liftJoinTop :: JoinFun a -> JoinFun (WithTop a)+extendJoinDomain :: forall a+              . (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a))+             -> JoinFun (WithTop a)++extendJoinDomain joinx = join+ where join :: JoinFun (WithTop a)+       join _ (OldFact Top)          (NewFact _)   = (NoChange, Top)+       join _ (OldFact _)            (NewFact Top) = (SomeChange, Top)+       join l (OldFact (PElem old)) (NewFact (PElem new))+           = joinx l (OldFact old) (NewFact new)++liftJoinTop joinx = extendJoinDomain (\l old new -> liftPair $ joinx l old new)+  where liftPair (c, a) = (c, PElem a)++-- | Given a join function and a name, creates a semi lattice by+-- adding a top element but no bottom element.  Caller must supply the bottom +-- element.+addTop  :: DataflowLattice a -> DataflowLattice (WithTop a)+-- | A more general case for creating a new lattice+addTop' :: forall a .+              String+           -> a+           -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a))+           -> DataflowLattice (WithTop a)++addTop lattice = addTop' name' (fact_bot lattice) join'+   where name' = fact_name lattice ++ " + T"+         join' l o n = (change, PElem f)+            where (change, f) = fact_join lattice l o n++addTop' name bot joinx = DataflowLattice name (PElem bot) join+  where -- careful: order of cases matters for ChangeFlag+        join :: JoinFun (WithTop a)+        join _ (OldFact Top)          (NewFact _)   = (NoChange, Top)+        join _ (OldFact _)            (NewFact Top) = (SomeChange, Top)+        join l (OldFact (PElem old)) (NewFact (PElem new))+           = joinx l (OldFact old) (NewFact new)++instance Show a => Show (Pointed t b a) where+  show Bot = "_|_"+  show Top = "T"+  show (PElem a) = show a++instance Functor (Pointed t b) where+  fmap _ Bot = Bot+  fmap _ Top = Top+  fmap f (PElem a) = PElem (f a)++instance Eq a => Eq (Pointed t b a) where+  Bot == Bot = True+  Top == Top = True+  (PElem a) == (PElem a') = a == a'+  _ == _ = False++instance Ord a => Ord (Pointed t b a) where+  Bot     `compare` Bot      = EQ+  Bot     `compare` _        = LT+  _       `compare` Bot      = GT+  PElem a `compare` PElem a' = a `compare` a'+  Top     `compare` Top      = EQ+  Top     `compare` _        = GT+  _       `compare` Top      = LT

@@ -0,0 +1,50 @@+{-# LANGUAGE GADTs, EmptyDataDecls #-}++module Compiler.Hoopl.Shape {-# DEPRECATED "not ready to migrate to this yet" #-}+where++-- | Used at the type level to indicate an "open" structure with    +-- a unique, unnamed control-flow edge flowing in or out.         +-- "Fallthrough" and concatenation are permitted at an open point.+data O +       +       +-- | Used at the type level to indicate a "closed" structure which+-- supports control transfer only through the use of named+-- labels---no "fallthrough" is permitted.  The number of control-flow+-- edges is unconstrained.+data C+++data HalfShape s where+  ShapeO :: HalfShape O+  ShapeC :: HalfShape C++data Shape e x where+  ShapeOO :: Shape O O+  ShapeCO :: Shape C O+  ShapeOC :: Shape O C+  ShapeCC :: Shape C C++class Shapely n where+  shape        :: n e x -> Shape e x+  shapeAtEntry :: n e x -> HalfShape e+  shapeAtExit  :: n e x -> HalfShape x++  shapeAtEntry = entryHalfShape . shape+  shapeAtExit  = exitHalfShape  . shape+  ++entryHalfShape :: Shape e x -> HalfShape e+exitHalfShape  :: Shape e x -> HalfShape x++entryHalfShape ShapeOO = ShapeO+entryHalfShape ShapeOC = ShapeO+entryHalfShape ShapeCO = ShapeC+entryHalfShape ShapeCC = ShapeC++exitHalfShape ShapeOO = ShapeO+exitHalfShape ShapeOC = ShapeC+exitHalfShape ShapeCO = ShapeO+exitHalfShape ShapeCC = ShapeC+

@@ -0,0 +1,41 @@+{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-}++module Compiler.Hoopl.Show +  ( showGraph, showFactBase+  )+where++import Compiler.Hoopl.Collections+import Compiler.Hoopl.Graph+import Compiler.Hoopl.Label++--------------------------------------------------------------------------------+-- Prettyprinting+--------------------------------------------------------------------------------++type Showing n = forall e x . n e x -> String+ ++showGraph :: forall n e x . (NonLocal n) => Showing n -> Graph n e x -> String+showGraph node = g+  where g :: (NonLocal n) => Graph n e x -> String+        g GNil = ""+        g (GUnit block) = b block+        g (GMany g_entry g_blocks g_exit) =+            open b g_entry ++ body g_blocks ++ open b g_exit+        body blocks = concatMap b (mapElems blocks)+        b :: forall e x . Block n e x -> String+        b (BFirst  n)     = node n+        b (BMiddle n)     = node n+        b (BLast   n)     = node n ++ "\n"+        b (BCat b1 b2)    = b b1   ++ b b2+        b (BHead b1 n)    = b b1   ++ node n ++ "\n"+        b (BTail n b1)    = node n ++ b b1+        b (BClosed b1 b2) = b b1   ++ b b2++open :: (a -> String) -> MaybeO z a -> String+open _ NothingO  = ""+open p (JustO n) = p n++showFactBase :: Show f => FactBase f -> String+showFactBase = show . mapToList

@@ -0,0 +1,138 @@+{-# LANGUAGE TypeFamilies #-}+module Compiler.Hoopl.Unique+  ( Unique, intToUnique+  , UniqueSet, UniqueMap+  , UniqueMonad(..)+  , SimpleUniqueMonad, runSimpleUniqueMonad+  , UniqueMonadT, runUniqueMonadT++  , uniqueToInt -- exposed through GHC module only!+  )++where++import Compiler.Hoopl.Checkpoint+import Compiler.Hoopl.Collections++import qualified Data.IntMap as M+import qualified Data.IntSet as S++-----------------------------------------------------------------------------+--		Unique+-----------------------------------------------------------------------------++data Unique = Unique { uniqueToInt ::  {-# UNPACK #-} !Int }+  deriving (Eq, Ord)++intToUnique :: Int -> Unique+intToUnique = Unique++instance Show Unique where+  show (Unique n) = show n++-----------------------------------------------------------------------------+-- UniqueSet++newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show)++instance IsSet UniqueSet where+  type ElemOf UniqueSet = Unique++  setNull (US s) = S.null s+  setSize (US s) = S.size s+  setMember (Unique k) (US s) = S.member k s++  setEmpty = US S.empty+  setSingleton (Unique k) = US (S.singleton k)+  setInsert (Unique k) (US s) = US (S.insert k s)+  setDelete (Unique k) (US s) = US (S.delete k s)++  setUnion (US x) (US y) = US (S.union x y)+  setDifference (US x) (US y) = US (S.difference x y)+  setIntersection (US x) (US y) = US (S.intersection x y)+  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y++  setFold k z (US s) = S.fold (k . intToUnique) z s++  setElems (US s) = map intToUnique (S.elems s)+  setFromList ks = US (S.fromList (map uniqueToInt ks))++-----------------------------------------------------------------------------+-- UniqueMap++newtype UniqueMap v = UM (M.IntMap v) deriving (Eq, Ord, Show)++instance IsMap UniqueMap where+  type KeyOf UniqueMap = Unique++  mapNull (UM m) = M.null m+  mapSize (UM m) = M.size m+  mapMember (Unique k) (UM m) = M.member k m+  mapLookup (Unique k) (UM m) = M.lookup k m+  mapFindWithDefault def (Unique k) (UM m) = M.findWithDefault def k m++  mapEmpty = UM M.empty+  mapSingleton (Unique k) v = UM (M.singleton k v)+  mapInsert (Unique k) v (UM m) = UM (M.insert k v m)+  mapDelete (Unique k) (UM m) = UM (M.delete k m)++  mapUnion (UM x) (UM y) = UM (M.union x y)+  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey (f . intToUnique) x y)+  mapDifference (UM x) (UM y) = UM (M.difference x y)+  mapIntersection (UM x) (UM y) = UM (M.intersection x y)+  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y++  mapMap f (UM m) = UM (M.map f m)+  mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m)+  mapFold k z (UM m) = M.fold k z m+  mapFoldWithKey k z (UM m) = M.foldWithKey (k . intToUnique) z m++  mapElems (UM m) = M.elems m+  mapKeys (UM m) = map intToUnique (M.keys m)+  mapToList (UM m) = [(intToUnique k, v) | (k, v) <- M.toList m]+  mapFromList assocs = UM (M.fromList [(uniqueToInt k, v) | (k, v) <- assocs])++----------------------------------------------------------------+-- Monads++class Monad m => UniqueMonad m where+  freshUnique :: m Unique++newtype SimpleUniqueMonad a = SUM { unSUM :: [Unique] -> (a, [Unique]) }++instance Monad SimpleUniqueMonad where+  return a = SUM $ \us -> (a, us)+  m >>= k  = SUM $ \us -> let (a, us') = unSUM m us in+                              unSUM (k a) us'++instance UniqueMonad SimpleUniqueMonad where+  freshUnique = SUM $ f+    where f (u:us) = (u, us)+          f _ = error "Unique.freshUnique(SimpleUniqueMonad): empty list"++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)++----------------------------------------------------------------++newtype UniqueMonadT m a = UMT { unUMT :: [Unique] -> m (a, [Unique]) }++instance Monad m => Monad (UniqueMonadT m) where+  return a = UMT $ \us -> return (a, us)+  m >>= k  = UMT $ \us -> do { (a, us') <- unUMT m us; unUMT (k a) us' }++instance Monad m => UniqueMonad (UniqueMonadT m) where+  freshUnique = UMT $ f+    where f (u:us) = return (u, us)+          f _ = error "Unique.freshUnique(UniqueMonadT): empty list"++runUniqueMonadT :: Monad m => UniqueMonadT m a -> m a+runUniqueMonadT m = do { (a, _) <- unUMT m allUniques; return a }++allUniques :: [Unique]+allUniques = map Unique [1..]

@@ -0,0 +1,268 @@+{-# LANGUAGE GADTs, ScopedTypeVariables, FlexibleInstances, RankNTypes, TypeFamilies #-}++module Compiler.Hoopl.Util+  ( gUnitOO, gUnitOC, gUnitCO, gUnitCC+  , catGraphNodeOC, catGraphNodeOO+  , catNodeCOGraph, catNodeOOGraph+  , graphMapBlocks+  , blockMapNodes, blockMapNodes3+  , blockGraph+  , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except+  , preorder_dfs, preorder_dfs_from_except+  , labelsDefined, labelsUsed, externalEntryLabels+  , LabelsPtr(..)+  )+where++import Control.Monad++import Compiler.Hoopl.Collections+import Compiler.Hoopl.Graph+import Compiler.Hoopl.Label+++----------------------------------------------------------------++gUnitOO :: block n O O -> Graph' block n O O+gUnitOC :: block n O C -> Graph' block n O C+gUnitCO :: block n C O -> Graph' block n C O+gUnitCC :: NonLocal (block n) => block n C C -> Graph' block n C C+gUnitOO b = GUnit b+gUnitOC b = GMany (JustO b) emptyBody  NothingO+gUnitCO b = GMany NothingO  emptyBody (JustO b)+gUnitCC b = GMany NothingO  (addBlock b emptyBody) NothingO+++catGraphNodeOO ::            Graph n e O -> n O O -> Graph n e O+catGraphNodeOC :: NonLocal n => Graph n e O -> n O C -> Graph n e C+catNodeOOGraph ::            n O O -> Graph n O x -> Graph n O x+catNodeCOGraph :: NonLocal n => n C O -> Graph n O x -> Graph n C x++catGraphNodeOO GNil                     n = gUnitOO $ BMiddle n+catGraphNodeOO (GUnit b)                n = gUnitOO $ b `BCat` BMiddle n+catGraphNodeOO (GMany e body (JustO x)) n = GMany e body (JustO $ x `BHead` n)++catGraphNodeOC GNil                     n = gUnitOC $ BLast n+catGraphNodeOC (GUnit b)                n = gUnitOC $ addToLeft b $ BLast n+  where addToLeft :: Block n O O -> Block n O C -> Block n O C+        addToLeft (BMiddle m)    g = m `BTail` g+        addToLeft (b1 `BCat` b2) g = addToLeft b1 $ addToLeft b2 g+catGraphNodeOC (GMany e body (JustO x)) n = GMany e body' NothingO+  where body' = addBlock (x `BClosed` BLast n) body++catNodeOOGraph n GNil                     = gUnitOO $ BMiddle n+catNodeOOGraph n (GUnit b)                = gUnitOO $ BMiddle n `BCat` b+catNodeOOGraph n (GMany (JustO e) body x) = GMany (JustO $ n `BTail` e) body x++catNodeCOGraph n GNil                     = gUnitCO $ BFirst n+catNodeCOGraph n (GUnit b)                = gUnitCO $ addToRight (BFirst n) b+  where addToRight :: Block n C O -> Block n O O -> Block n C O+        addToRight g (BMiddle m)    = g `BHead` m+        addToRight g (b1 `BCat` b2) = addToRight (addToRight g b1) b2+catNodeCOGraph n (GMany (JustO e) body x) = GMany NothingO body' x+  where body' = addBlock (BFirst n `BClosed` e) body++++++blockGraph :: NonLocal n => Block n e x -> Graph n e x+blockGraph b@(BFirst  {}) = gUnitCO b+blockGraph b@(BMiddle {}) = gUnitOO b+blockGraph b@(BLast   {}) = gUnitOC b+blockGraph b@(BCat {})    = gUnitOO b+blockGraph b@(BHead {})   = gUnitCO b+blockGraph b@(BTail {})   = gUnitOC b+blockGraph b@(BClosed {}) = gUnitCC b+++-- | Function 'graphMapBlocks' enables a change of representation of blocks,+-- nodes, or both.  It lifts a polymorphic block transform into a polymorphic+-- graph transform.  When the block representation stabilizes, a similar+-- function should be provided for blocks.+graphMapBlocks :: forall block n block' n' e x .+                  (forall e x . block n e x -> block' n' e x)+               -> (Graph' block n e x -> Graph' block' n' e x)++graphMapBlocks f = map+  where map :: Graph' block n e x -> Graph' block' n' e x+        map GNil = GNil+        map (GUnit b) = GUnit (f b)+        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)++-- | Function 'blockMapNodes' enables a change of nodes in a block.+blockMapNodes3 :: ( n C O -> n' C O+                  , n O O -> n' O O+                  , n O C -> n' O C)+               -> Block n e x -> Block n' e x+blockMapNodes3 (f, _, _) (BFirst n)     = BFirst (f n)+blockMapNodes3 (_, m, _) (BMiddle n)    = BMiddle (m n)+blockMapNodes3 (_, _, l) (BLast n)      = BLast (l n)+blockMapNodes3 fs (BCat x y)            = BCat (blockMapNodes3 fs x) (blockMapNodes3 fs y)+blockMapNodes3 fs@(_, m, _) (BHead x n) = BHead (blockMapNodes3 fs x) (m n)+blockMapNodes3 fs@(_, m, _) (BTail n x) = BTail (m n) (blockMapNodes3 fs x)+blockMapNodes3 fs (BClosed x y)         = BClosed (blockMapNodes3 fs x) (blockMapNodes3 fs y)++blockMapNodes :: (forall e x. n e x -> n' e x)+              -> (Block n e x -> Block n' e x)+blockMapNodes f = blockMapNodes3 (f, f, f)++----------------------------------------------------------------++class LabelsPtr l where+  targetLabels :: l -> [Label]++instance NonLocal n => LabelsPtr (n e C) where+  targetLabels n = successors n++instance LabelsPtr Label where+  targetLabels l = [l]++instance LabelsPtr LabelSet where+  targetLabels = setElems++instance LabelsPtr l => LabelsPtr [l] where+  targetLabels = concatMap targetLabels+++-- | Traversal: 'postorder_dfs' returns a list of blocks reachable+-- from the entry of enterable graph. The entry and exit are *not* included.+-- The list has the following property:+--+--	Say a "back reference" exists if one of a block's+--	control-flow successors precedes it in the output list+--+--	Then there are as few back references as possible+--+-- The output is suitable for use in+-- a forward dataflow problem.  For a backward problem, simply reverse+-- the list.  ('postorder_dfs' is sufficiently tricky to implement that+-- one doesn't want to try and maintain both forward and backward+-- versions.)++postorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C]+preorder_dfs  :: NonLocal (block n) => Graph' block n O x -> [block n C C]++-- | This is the most important traversal over this data structure.  It drops+-- unreachable code and puts blocks in an order that is good for solving forward+-- dataflow problems quickly.  The reverse order is good for solving backward+-- dataflow problems quickly.  The forward order is also reasonably good for+-- emitting instructions, except that it will not usually exploit Forrest+-- Baskett's trick of eliminating the unconditional branch from a loop.  For+-- that you would need a more serious analysis, probably based on dominators, to+-- identify loop headers.+--+-- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'+-- representation, when for most purposes the plain 'Graph' representation is+-- more mathematically elegant (but results in more complicated code).+--+-- Here's an easy way to go wrong!  Consider+-- @+--	A -> [B,C]+--	B -> D+--	C -> D+-- @+-- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.+-- Better to get [A,B,C,D]+++graphDfs :: (NonLocal (block n))+         => (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C])+         -> (Graph' block n O x -> [block n C C])+graphDfs _     (GNil)    = []+graphDfs _     (GUnit{}) = []+graphDfs order (GMany (JustO entry) body _) = order body entry setEmpty++postorder_dfs = graphDfs postorder_dfs_from_except+preorder_dfs  = graphDfs preorder_dfs_from_except++postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)+                          => LabelMap (block C C) -> e -> LabelSet -> [block C C]+postorder_dfs_from_except blocks b visited =+ vchildren (get_children b) (\acc _visited -> acc) [] visited+ where+   vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a+   vnode block cont acc visited =+        if setMember id visited then+            cont acc visited+        else+            let cont' acc visited = cont (block:acc) visited in+            vchildren (get_children block) cont' acc (setInsert id visited)+      where id = entryLabel block+   vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a+   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 :: forall l. LabelsPtr l => l -> [block C C]+   get_children block = foldr add_id [] $ targetLabels block+   add_id id rst = case lookupFact id blocks of+                      Just b -> b : rst+                      Nothing -> rst++postorder_dfs_from+    :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]+postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty+++----------------------------------------------------------------++data VM a = VM { unVM :: LabelSet -> (a, LabelSet) }+marked :: Label -> VM Bool+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 -> (setMember l v, v)+mark   l = VM $ \v -> ((), setInsert l v)++preorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)+                         => LabelMap (block C C) -> e -> LabelSet -> [block C C]+preorder_dfs_from_except blocks b visited =+    (fst $ unVM (children (get_children b)) visited) []+  where children [] = return id+        children (b:bs) = liftM2 (.) (visit b) (children bs)+        visit :: block C C -> VM (HL (block C C))+        visit b = do already <- marked (entryLabel b)+                     if already then return id+                      else do mark (entryLabel b)+                              bs <- children $ get_children b+                              return $ b `cons` bs+        get_children :: forall l. LabelsPtr l => l -> [block C C]+        get_children block = foldr add_id [] $ targetLabels block+        add_id id rst = case lookupFact id blocks of+                          Just b -> b : rst+                          Nothing -> rst++type HL a = [a] -> [a] -- Hughes list (constant-time concatenation)+cons :: a -> HL a -> HL a+cons a as tail = a : as tail++----------------------------------------------------------------++labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x -> LabelSet+labelsDefined GNil      = setEmpty+labelsDefined (GUnit{}) = setEmpty+labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body+  where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet+        addEntry label _ labels = setInsert label labels+        exitLabel :: MaybeO x (block n C O) -> LabelSet+        exitLabel NothingO  = setEmpty+        exitLabel (JustO b) = setSingleton (entryLabel b)++labelsUsed :: forall block n e x. NonLocal (block n) => Graph' block n e x -> LabelSet+labelsUsed GNil      = setEmpty+labelsUsed (GUnit{}) = setEmpty+labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body +  where addTargets :: forall e. block n e C -> LabelSet -> LabelSet+        addTargets block labels = setInsertList (successors block) labels+        entryTargets :: MaybeO e (block n O C) -> LabelSet+        entryTargets NothingO = setEmpty+        entryTargets (JustO b) = addTargets b setEmpty++externalEntryLabels :: forall n .+                       NonLocal n => LabelMap (Block n C C) -> LabelSet+externalEntryLabels body = defined `setDifference` used+  where defined = labelsDefined g+        used = labelsUsed g+        g = GMany NothingO body NothingO

@@ -0,0 +1,7 @@+module Compiler.Hoopl.Wrappers {-# DEPRECATED "Use only if you know what you are doing and can preserve the 'respects fuel' invariant" #-}+  ( wrapFR, wrapFR2, wrapBR, wrapBR2+  )+where++import Compiler.Hoopl.Dataflow+

@@ -0,0 +1,508 @@+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies  #-}++-- | Utilities for clients of Hoopl, not used internally.++module Compiler.Hoopl.XUtil+  ( firstXfer, distributeXfer+  , distributeFact, distributeFactBwd+  , successorFacts+  , joinFacts+  , joinOutFacts -- deprecated+  , joinMaps+  , foldGraphNodes+  , foldBlockNodesF, foldBlockNodesB, foldBlockNodesF3, foldBlockNodesB3+  , tfFoldBlock+  , ScottBlock(ScottBlock), scottFoldBlock+  , fbnf3+  , blockToNodeList, blockOfNodeList+  , blockToNodeList'   -- alternate version using fold+  , blockToNodeList''  -- alternate version using scottFoldBlock+  , blockToNodeList''' -- alternate version using tfFoldBlock+  , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody+  , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx+  , noEntries+  , BlockResult(..), lookupBlock+  )+where++import qualified Data.Map as M+import Data.Maybe++import Compiler.Hoopl.Checkpoint+import Compiler.Hoopl.Collections+import Compiler.Hoopl.Dataflow+import Compiler.Hoopl.Graph+import Compiler.Hoopl.Label+import Compiler.Hoopl.Util+++-- | Forward dataflow analysis and rewriting for the special case of a Body.+-- A set of entry points must be supplied; blocks not reachable from+-- the set are thrown away.+analyzeAndRewriteFwdBody+   :: 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)++-- | Backward dataflow analysis and rewriting for the special case of a Body.+-- A set of entry points must be supplied; blocks not reachable from+-- the set are thrown away.+analyzeAndRewriteBwdBody+   :: 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)++analyzeAndRewriteFwdBody pass en = mapBodyFacts (analyzeAndRewriteFwd pass (JustC en))+analyzeAndRewriteBwdBody pass en = mapBodyFacts (analyzeAndRewriteBwd pass (JustC en))++mapBodyFacts :: (Monad m)+    => (Graph n C C -> Fact C f   -> m (Graph n C C, Fact C f, MaybeO C f))+    -> (Body n      -> FactBase f -> m (Body n, FactBase f))+-- ^ Internal utility; should not escape+mapBodyFacts anal b f = anal (GMany NothingO b NothingO) f >>= bodyFacts+  where -- the type constraint is needed for the pattern match;+        -- if it were not, we would use do-notation here.+    bodyFacts :: Monad m => (Graph n C C, Fact C f, MaybeO C f) -> m (Body n, Fact C f)+    bodyFacts (GMany NothingO body NothingO, fb, NothingO) = return (body, fb)++{-+  Can't write:++     do (GMany NothingO body NothingO, fb, NothingO) <- anal (....) f+        return (body, fb)++  because we need an explicit type signature in order to do the GADT+  pattern matches on NothingO+-}++++-- | Forward dataflow analysis and rewriting for the special case of a +-- graph open at the entry.  This special case relieves the client+-- 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. (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 +-- graph open at the entry.  This special case relieves the client+-- 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. (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.+noEntries :: MaybeC O Label+noEntries = NothingC++analyzeAndRewriteFwdOx pass g f  = analyzeAndRewriteFwd pass noEntries g f+analyzeAndRewriteBwdOx pass g fb = analyzeAndRewriteBwd pass noEntries g fb >>= strip+  where strip :: forall m a b c . Monad m => (a, b, MaybeO O c) -> m (a, b, c)+        strip (a, b, JustO c) = return (a, b, c)++++++-- | A utility function so that a transfer function for a first+-- node can be given just a fact; we handle the lookup.  This+-- function is planned to be made obsolete by changes in the dataflow+-- interface.++firstXfer :: NonLocal n => (n C O -> f -> f) -> (n C O -> FactBase f -> f)+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+               => 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 = 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 = mapSingleton (entryLabel n) f++-- | List of (unlabelled) facts from the successors of a last node+successorFacts :: NonLocal n => n O C -> FactBase f -> [f]+successorFacts n fb = [ f | id <- successors n, let Just f = lookupFact id fb ]++-- | Join a list of facts.+joinFacts :: DataflowLattice f -> Label -> [f] -> f+joinFacts lat inBlock = foldr extend (fact_bot lat)+  where extend new old = snd $ fact_join lat inBlock (OldFact old) (NewFact new)++{-# DEPRECATED joinOutFacts+    "should be replaced by 'joinFacts lat l (successorFacts n f)'; as is, it uses the wrong Label" #-}++joinOutFacts :: (NonLocal node) => DataflowLattice f -> node O C -> FactBase f -> f+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]+++-- | It's common to represent dataflow facts as a map from variables+-- to some fact about the locations. For these maps, the join+-- operation on the map can be expressed in terms of the join on each+-- element of the codomain:+joinMaps :: Ord k => JoinFun v -> JoinFun (M.Map k v)+joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldrWithKey add (NoChange, old) new+  where +    add k new_v (ch, joinmap) =+      case M.lookup k joinmap of+        Nothing    -> (SomeChange, M.insert k new_v joinmap)+        Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of+                        (SomeChange, v') -> (SomeChange, M.insert k v' joinmap)+                        (NoChange,   _)  -> (ch, joinmap)++++-- | 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 -> 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 -> IndexedCO x c (IndexedCO e bc bo)+        block (BFirst  n)       = f n+        block (BMiddle n)       = m n bo+        block (BLast   n)       = l n bo+        block (b1 `BCat`    b2) = oblock b2 $ block b1+        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 -> 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+        oblock (n `BTail` b2)    = m n       `cat` oblock b2+        cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c+        cat f f' = f' . f+++type NodeList' e x n = (MaybeC e (n C O), [n O O], MaybeC x (n O C))+blockToNodeList''' ::+  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+    (h, ms', t) = tfFoldBlock (f, m, l) b z+    z :: NodeList' O O n+    z = (NothingC, [], NothingC)+    f :: n C O -> NodeList' C O n+    f n = (JustC n,  [], NothingC)+    m n (h, ms', t) = (h, n : ms', t)+    l n (h, ms', _) = (h, ms', JustC n)+++{-+data EitherCO' ex a b where+  LeftCO  :: a -> EitherCO' C a b+  RightCO :: b -> EitherCO' O a b+-}++  -- should be done with a *backward* fold++-- | More general fold++_unused :: Int+_unused = 3+  where _a = foldBlockNodesF3'' (Trips undefined undefined undefined)+        _b = foldBlockNodesF3'++data Trips n a b c = Trips { ff :: forall e . MaybeC e (n C O) -> a -> b+                           , fm :: n O O            -> b -> b+                           , fl :: forall x . MaybeC x (n O C) -> b -> c+                           }++foldBlockNodesF3'' :: forall n a b c .+                      Trips n a b c -> (forall e x . Block n e x -> a -> c)+foldBlockNodesF3'' trips = block+  where block :: Block n e x -> a -> c+        block (b1 `BClosed` b2) = foldCO b1 `cat` foldOC b2+        block (BFirst  node)    = ff trips (JustC node)  `cat` missingLast+        block (b @ BHead {})    = foldCO b `cat` missingLast+        block (BMiddle node)    = missingFirst `cat` fm trips node  `cat` missingLast+        block (b @ BCat {})     = missingFirst `cat` foldOO b `cat` missingLast+        block (BLast   node)    = missingFirst `cat` fl trips (JustC node)+        block (b @ BTail {})    = missingFirst `cat` foldOC b+        missingLast = fl trips NothingC+        missingFirst = ff trips NothingC+        foldCO :: Block n C O -> a -> b+        foldOO :: Block n O O -> b -> b+        foldOC :: Block n O C -> b -> c+        foldCO (BFirst n)   = ff trips (JustC n)+        foldCO (BHead b n)  = foldCO b `cat` fm trips n+        foldOO (BMiddle n)  = fm trips n+        foldOO (BCat b1 b2) = foldOO b1 `cat` foldOO b2+        foldOC (BLast n)    = fl trips (JustC n)+        foldOC (BTail n b)  = fm trips n `cat` foldOC b+        cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c+        f `cat` g = g . f ++data ScottBlock n a = ScottBlock+   { sb_first :: n C O -> a C O+   , sb_mid   :: n O O -> a O O+   , sb_last  :: n O C -> a O C+   , sb_cat   :: forall e x . a e O -> a O x -> a e x+   }++scottFoldBlock :: forall n a e x . ScottBlock n a -> Block n e x -> a e x+scottFoldBlock funs = block+  where block :: forall e x . Block n e x -> a e x+        block (BFirst n)  = sb_first  funs n+        block (BMiddle n) = sb_mid    funs n+        block (BLast   n) = sb_last   funs n+        block (BClosed b1 b2) = block b1 `cat` block b2+        block (BCat    b1 b2) = block b1 `cat` block b2+        block (BHead   b  n)  = block b  `cat` sb_mid funs n+        block (BTail   n  b)  = sb_mid funs n `cat` block b+        cat :: forall e x. a e O -> a O x -> a e x+        cat = sb_cat funs++newtype NodeList n e x+    = NL { unList :: (MaybeC e (n C O), [n O O] -> [n O O], MaybeC x (n O C)) }++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 -> 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+          -- XXX Ew.+          cat :: forall t t1 t2 t3 t4 t5 t6 t7 t8 t9 a b c e x.+                 (IndexedCO x c b ~ IndexedCO t9 t7 t6,+                  IndexedCO t8 t5 t6 ~ IndexedCO t4 t2 t1,+                  IndexedCO t3 t t1 ~ IndexedCO e a b) =>+                 FF3 t t1 t2 t3 t4 -> FF3 t5 t6 t7 t8 t9 -> FF3 a b c e x+          FF3 f `cat` FF3 f' = FF3 $ f' . f++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)+    where f n = NL (JustC n, id, NothingC)+          m n = NL (NothingC, (n:), NothingC)+          l n = NL (NothingC, id, JustC n)+          cat :: forall n t1 t2 t3. NodeList n t1 t2 -> NodeList n t2 t3 -> NodeList n t1 t3+          NL (e, ms, NothingC) `cat` NL (NothingC, ms', x) = NL (e, ms . ms', x)+          finish :: forall t t1 t2 a. (t, [a] -> t1, t2) -> (t, t1, t2)+          finish (e, ms, x) = (e, ms [], x)++++blockToNodeList' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))+blockToNodeList' b = unFNL $ foldBlockNodesF3''' ff fm fl b ()+  where ff :: forall n e. MaybeC e (n C O) -> () -> PNL n e+        fm :: forall n e. n O O -> PNL n e -> PNL n e+        fl :: forall n e x. MaybeC x (n O C) -> PNL n e -> FNL n e x+        ff n () = PNL (n, [])+        fm n (PNL (first, mids')) = PNL (first, n : mids')+        fl n (PNL (first, mids')) = FNL (first, reverse mids', n)++   -- newtypes for 'partial node list' and 'final node list'+newtype PNL n e   = PNL (MaybeC e (n C O), [n O O])+newtype FNL n e x = FNL {unFNL :: (MaybeC e (n C O), [n O O], MaybeC x (n O C))}++foldBlockNodesF3''' :: forall n a b c .+                       (forall e   . MaybeC e (n C O) -> a   -> b e)+                    -> (forall e   .           n O O  -> b e -> b e)+                    -> (forall e x . MaybeC x (n O C) -> b e -> c e x)+                    -> (forall e x . Block n e x      -> a   -> c e x)+foldBlockNodesF3''' ff fm fl = block+  where block   :: forall e x . Block n e x -> a   -> c e x+        blockCO ::              Block n C O -> a   -> b C+        blockOO :: forall e .   Block n O O -> b e -> b e+        blockOC :: forall e .   Block n O C -> b e -> c e C+        block (b1 `BClosed` b2) = blockCO b1       `cat` blockOC b2+        block (BFirst  node)    = ff (JustC node)  `cat` fl NothingC+        block (b @ BHead {})    = blockCO b        `cat` fl NothingC+        block (BMiddle node)    = ff NothingC `cat` fm node   `cat` fl NothingC+        block (b @ BCat {})     = ff NothingC `cat` blockOO b `cat` fl NothingC+        block (BLast   node)    = ff NothingC `cat` fl (JustC node)+        block (b @ BTail {})    = ff NothingC `cat` blockOC b+        blockCO (BFirst n)      = ff (JustC n)+        blockCO (BHead b n)     = blockCO b `cat` fm n+        blockOO (BMiddle n)     = fm n+        blockOO (BCat b1 b2)    = blockOO b1 `cat` blockOO b2+        blockOC (BLast n)       = fl (JustC n)+        blockOC (BTail n b)     = fm n `cat` blockOC b+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c+        f `cat` g = g . f +++-- | The following function is easy enough to define but maybe not so useful+foldBlockNodesF3' :: forall n a b c .+                   ( n C O -> a -> b+                   , n O O -> b -> b+                   , n O C -> b -> c)+                   -> (a -> b) -- called iff there is no first node+                   -> (b -> c) -- called iff there is no last node+                   -> (forall e x . Block n e x -> a -> c)+foldBlockNodesF3' (ff, fm, fl) missingFirst missingLast = block+  where block   :: forall e x . Block n e x -> a -> c+        blockCO ::              Block n C O -> a -> b+        blockOO ::              Block n O O -> b -> b+        blockOC ::              Block n O C -> b -> c+        block (b1 `BClosed` b2) = blockCO b1 `cat` blockOC b2+        block (BFirst  node)    = ff node  `cat` missingLast+        block (b @ BHead {})    = blockCO b `cat` missingLast+        block (BMiddle node)    = missingFirst `cat` fm node  `cat` missingLast+        block (b @ BCat {})     = missingFirst `cat` blockOO b `cat` missingLast+        block (BLast   node)    = missingFirst `cat` fl node+        block (b @ BTail {})    = missingFirst `cat` blockOC b+        blockCO (BFirst n)   = ff n+        blockCO (BHead b n)  = blockCO b `cat` fm n+        blockOO (BMiddle n)  = fm n+        blockOO (BCat b1 b2) = blockOO b1 `cat` blockOO b2+        blockOC (BLast n)    = fl n+        blockOC (BTail n b)  = fm n `cat` blockOC b+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c+        f `cat` g = g . f ++-- | Fold a function over every node in a block, forward or backward.+-- The fold function must be polymorphic in the shape of the nodes.+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 -> 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 -> 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 -> 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 -> 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.++foldGraphNodes :: forall n a .+                  (forall e x . n e x       -> a -> a)+               -> (forall e x . Graph n e x -> a -> a)+++foldBlockNodesF3 (ff, fm, fl) = block+  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+        block (b1 `BCat`    b2) = block b1 `cat` block b2+        block (b1 `BClosed` b2) = block b1 `cat` block b2+        block (b1 `BHead` n)    = block b1 `cat` fm n+        block (n `BTail` b2)    = fm n `cat` block b2+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c+        cat f f' = f' . f+foldBlockNodesF f = foldBlockNodesF3 (f, f, f)++foldBlockNodesB3 (ff, fm, fl) = block+  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+        block (b1 `BCat`    b2) = block b1 `cat` block b2+        block (b1 `BClosed` b2) = block b1 `cat` block b2+        block (b1 `BHead` n)    = block b1 `cat` fm n+        block (n `BTail` b2)    = fm n `cat` block b2+        cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c+        cat f f' = f . f'+foldBlockNodesB f = foldBlockNodesB3 (f, f, f)+++foldGraphNodes f = graph+    where graph :: forall e x . Graph n e x -> a -> a+          lift  :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a)++          graph GNil              = id+          graph (GUnit b)         = block b+          graph (GMany e b x)     = lift block e . body b . lift block x+          body :: Body n -> a -> a+          body bdy                = \a -> mapFold block a bdy+          lift _ NothingO         = id+          lift f (JustO thing)    = f thing++          block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a+          block = foldBlockNodesF f++{-# DEPRECATED blockToNodeList, blockOfNodeList +  "What justifies these functions?  Can they be eliminated?  Replaced with folds?" #-}++++-- | Convert a block to a list of nodes. The entry and exit node+-- is or is not present depending on the shape of the block.+--+-- The blockToNodeList function cannot be currently expressed using+-- 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.+blockToNodeList :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))+blockToNodeList block = case block of+  BFirst n    -> (JustC n, [], NothingC)+  BMiddle n   -> (NothingC, [n], NothingC)+  BLast n     -> (NothingC, [], JustC n)+  BCat {}     -> (NothingC, foldOO block [], NothingC)+  BHead x n   -> case foldCO x [n] of (f, m) -> (f, m, NothingC)+  BTail n x   -> case foldOC x of (m, l) -> (NothingC, n : m, l)+  BClosed x y -> case foldOC y of (m, l) -> case foldCO x m of (f, m') -> (f, m', l)+  where foldCO :: Block n C O -> [n O O] -> (MaybeC C (n C O), [n O O])+        foldCO (BFirst n) m  = (JustC n, m)+        foldCO (BHead x n) m = foldCO x (n : m)++        foldOO :: Block n O O -> [n O O] -> [n O O]+        foldOO (BMiddle n) acc = n : acc+        foldOO (BCat x y) acc  = foldOO x $ foldOO y acc++        foldOC :: Block n O C -> ([n O O], MaybeC C (n O C))+        foldOC (BLast n)   = ([], JustC n)+        foldOC (BTail n x) = case foldOC x of (m, l) -> (n : m, l)++-- | Convert a list of nodes to a block. The entry and exit node+-- must or must not be present depending on the shape of the block.+blockOfNodeList :: (MaybeC e (n C O), [n O O], MaybeC x (n O C)) -> Block n e x+blockOfNodeList (NothingC, [], NothingC) = error "No nodes to created block from in blockOfNodeList"+blockOfNodeList (NothingC, m, NothingC)  = foldr1 BCat (map BMiddle m)+blockOfNodeList (NothingC, m, JustC l)   = foldr BTail (BLast l) m+blockOfNodeList (JustC f, m, NothingC)   = foldl BHead (BFirst f) m+blockOfNodeList (JustC f, m, JustC l)    = BClosed (BFirst f) $ foldr BTail (BLast l) m++data BlockResult n x where+  NoBlock   :: BlockResult n x+  BodyBlock :: Block n C C -> BlockResult n x+  ExitBlock :: Block n C O -> BlockResult n O++lookupBlock :: NonLocal n => Graph n e x -> Label -> BlockResult n x+lookupBlock (GMany _ _ (JustO exit)) lbl+  | entryLabel exit == lbl = ExitBlock exit+lookupBlock (GMany _ body _) lbl =+  case mapLookup lbl body of+    Just b  -> BodyBlock b+    Nothing -> NoBlock+lookupBlock GNil      _ = NoBlock+lookupBlock (GUnit _) _ = NoBlock