hoopl 3.7.12.1 → 3.8.3.0

raw patch · 25 files changed

+2571/−2027 lines, 25 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +123/−0
• Compiler/Hoopl.hs +22/−8
• Compiler/Hoopl/Collections.hs +85/−0
• Compiler/Hoopl/Combinators.hs +218/−55
• Compiler/Hoopl/Dataflow.hs +485/−346
• Compiler/Hoopl/Debug.hs +58/−10
• Compiler/Hoopl/Fuel.hs +72/−23
• Compiler/Hoopl/GHC.hs +24/−0
• Compiler/Hoopl/Graph.hs +77/−34
• Compiler/Hoopl/GraphUtil.hs +88/−29
• Compiler/Hoopl/Label.hs +73/−79
• Compiler/Hoopl/MkGraph.hs +174/−157
• Compiler/Hoopl/Passes/DList.hs +45/−0
• Compiler/Hoopl/Passes/Dominator.hs +130/−0
• Compiler/Hoopl/Pointed.hs +147/−0
• Compiler/Hoopl/Show.hs +16/−6
• Compiler/Hoopl/Unique.hs +128/−0
• Compiler/Hoopl/Util.hs +107/−60
• Compiler/Hoopl/XUtil.hs +467/−0
• Compiler/Hoopl/ZipDataflow.hs +0/−568
• Compiler/Hoopl/ZipDataflowNoRG.hs +0/−556
• Compiler/Hoopl/Zipper.hs +0/−90
• FAQ +20/−0
• hoopl.cabal +12/−6
• hoopl.pdf binary

@@ -1,3 +1,126 @@+3.8.1.0++  Major reorganization per simonpj visit to Tufts 20 April 2010+  Collections++3.7.13.1++  Added function to fold over nodes in graph.++3.7.13.0++  Pointed type replaces WithTop and WithBot, which are now synonyms.+  ++3.7.12.3++  Updates to Hoopl in the last week+  =================================+++  Interface changes+  -----------------+  The type of AGraph is now abstract.+  It is now recommended to create AGraphs with just three functions:++    <*>          concatenation+    |*><*|       splicing at a closed point+    addBlocks    add C/C blocks out of line++  There are new utility functions in modules Util and XUtil, all+  exported by Compiler.Hoopl.  Here's a selection:++    -- | 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 :: Edges n => (n C O -> f -> f) -> (n C O -> FactBase f -> f)+    firstXfer xfer n fb = xfer n $ fromJust $ lookupFact fb $ entryLabel n+    +    -- | 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 :: Edges n => (n O C -> f -> f) -> (n O C -> f -> FactBase f)+    distributeXfer xfer n f = mkFactBase [ (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 :: Edges n => n O C -> f -> FactBase f++    -- | 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)++    postorder_dfs :: Edges (block n) => Graph' block n O x -> [block n C C]++  There are quite a few other variations related to depth-first traversal.+++  There is a new module Compiler.Hoopl.Pointed, which uses GADTs to+  enable you to add a Top or Bot element to a lattice, or both, all+  using the same type.  (Types 'WithBot' and 'WithTop' in XUtil,+  exported by Compiler.Hoopl, do similar jobs, but I think they are+  inferior.  Your opinion is solicited.)++  I added a function showGraph to print Graphs.  Right now it requires a+  polymorphic node-showing function as argument. When we change the+  Block representation we may get enough static type information that we+  can simply have an instance declaration for ++    instance (Show n C O, Show n O O, Show n O C) => Show (Graph n e x)++  At present, I don't see how to achieve such a declaration.+++  John added new functions 'debugFwdJoins' and 'debugBwdJoins' to extend+  passes with debugging information.++  We added primed versions of the analyzeAndRewrite functions, which+  operate on Graph, not Body.  Recommended, at least for first-timers.++  Not all maps keyed by Label are FactBases, so there is now a new set+  of names of functions to manipulate LabelMaps that do not contain+  dataflow facts.++++  Implementation changes+  ----------------------+  Split pass and rewrite-function combinators into Compiler.Hoopl.Combinators.++  Changed order of blocks for forward and backward analysis.+  These changes have not been tested, because we don't have a true+  regression suite yet.++  Graph and Body types now have more polymorphic variants Graph' and Body'.++  Lots of experiments with zippers.++++  Changes ahead+  -------------+  ForwardTransfer will become an abstract type, and clients will have+  two ways to create ForwardTransfers: as now, with a single,+  polymorphic transfer function; or with a triple of monomorphic+  transfer functions.  The implementation will use monomorphic+  functions, which will enable more useful combinators on passes,+  including adding more debugging information and enabling us to combine+  passes. ++  Perhaps we should provide splicing and 'addBlocks' on Graph?++  Change of block representation to have three monomorphic unit+  constructors and one polymorphic concatenation constructor.++  Graph body to be represented by a finite map; add functions to check+  for duplicate labels.+ 3.7.12.1    - Added a bunch of zipper experiments.

@@ -1,20 +1,34 @@ module Compiler.Hoopl-  ( module Compiler.Hoopl.Combinators+  ( module Compiler.Hoopl.Graph+  , module Compiler.Hoopl.MkGraph+  , module Compiler.Hoopl.XUtil+  , module Compiler.Hoopl.Collections   , module Compiler.Hoopl.Dataflow-  , module Compiler.Hoopl.Debug-  , module Compiler.Hoopl.Fuel-  , module Compiler.Hoopl.Graph   , module Compiler.Hoopl.Label-  , module Compiler.Hoopl.MkGraph+  , 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.Collections import Compiler.Hoopl.Combinators import Compiler.Hoopl.Dataflow import Compiler.Hoopl.Debug-import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel)-import Compiler.Hoopl.Graph hiding (BodyEmpty, BodyUnit, BodyCat)-import Compiler.Hoopl.Label hiding (allLabels)+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,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

@@ -1,79 +1,242 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables #-}  module Compiler.Hoopl.Combinators-  ( SimpleFwdRewrite, noFwdRewrite, thenFwdRw, shallowFwdRw, deepFwdRw, iterFwdRw-  , SimpleBwdRewrite, noBwdRewrite, thenBwdRw, shallowBwdRw, deepBwdRw, iterBwdRw+  ( SimpleFwdRewrite, SimpleFwdRewrite3, noFwdRewrite, thenFwdRw+  , shallowFwdRw3, shallowFwdRw, deepFwdRw3, deepFwdRw, iterFwdRw+  , SimpleBwdRewrite, SimpleBwdRewrite3, noBwdRewrite, thenBwdRw+  , shallowBwdRw3, shallowBwdRw, deepBwdRw3, deepBwdRw, iterBwdRw+  , pairFwd, pairBwd, pairLattice   )  where +import Control.Monad+import Data.Function+import Data.Maybe++import Compiler.Hoopl.Collections import Compiler.Hoopl.Dataflow-import Compiler.Hoopl.MkGraph+import Compiler.Hoopl.Graph (Graph, C, O)+import Compiler.Hoopl.Label -type SimpleFwdRewrite n f -  = forall e x. n e x -> Fact e f-             -> Maybe (AGraph n e x)+type FR m n f = FwdRewrite m n f+type BR m n f = BwdRewrite m n f -noFwdRewrite :: FwdRewrite n f-noFwdRewrite _ _ = Nothing+type FwdRes m n f e x = Maybe (FwdRew m n f e x) -shallowFwdRw :: SimpleFwdRewrite n f -> FwdRewrite n f-shallowFwdRw rw n f = case (rw n f) of-                         Nothing -> Nothing-                         Just ag -> Just (FwdRes ag noFwdRewrite)+type SFRW m n f e x = n e x -> f -> m (Maybe (Graph n e x))+type FRW  m n f e x = n e x -> f -> m (FwdRes m n f e x)+type SimpleFwdRewrite3 m n f = ExTriple (SFRW m n f)+type ExTriple a = (a C O, a O O, a O C) -- ^ entry/exit triple+type SimpleFwdRewrite m n f = forall e x . SFRW m n f e x+type LiftFRW m n f e x = SFRW m n f e x -> FRW m n f e x+type MapFRW  m n f e x = FRW  m n f e x -> FRW m n f e x+type MapFRW2 m n f e x = FRW  m n f e x -> FRW m n f e x -> FRW m n f e x -deepFwdRw :: SimpleFwdRewrite n f -> FwdRewrite n f-deepFwdRw r = iterFwdRw (shallowFwdRw r)+----------------------------------------------------------------+-- common operations on triples -thenFwdRw :: FwdRewrite n f -> FwdRewrite n f -> FwdRewrite n f-thenFwdRw rw1 rw2 n f-  = case rw1 n f of-      Nothing               -> rw2 n f-      Just (FwdRes ag rw1a) -> Just (FwdRes ag (rw1a `thenFwdRw` rw2))+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (a, b, c) = f a b c -iterFwdRw :: FwdRewrite n f -> FwdRewrite n f-iterFwdRw rw =-  \ n f -> case rw n f of-             Just (FwdRes g rw2) -> Just $ FwdRes g (rw2 `thenFwdRw` iterFwdRw rw)-             Nothing             -> Nothing+apply :: (a -> b, d -> e, g -> h) -> (a, d, g) -> (b, e, h)+apply (f1, f2, f3) (x1, x2, x3) = (f1 x1, f2 x2, f3 x3) +applyBinary :: (a -> b -> c, d -> e -> f, g -> h -> i)+            -> (a, d, g) -> (b, e, h) -> (c, f, i)+applyBinary (f1, f2, f3) (x1, x2, x3) (y1, y2, y3) = (f1 x1 y1, f2 x2 y2, f3 x3 y3)++ ---------------------------------------------------------------- -type SimpleBwdRewrite n f -  = forall e x. n e x -> Fact x f-             -> Maybe (AGraph n e x)+wrapSFRewrite3 :: ExTriple (LiftFRW m n f) -> SimpleFwdRewrite3 m n f -> FR m n f+wrapSFRewrite3 lift rw = uncurry3 mkFRewrite3 $ apply lift rw -noBwdRewrite :: BwdRewrite n f-noBwdRewrite _ _ = Nothing+wrapFRewrite3 :: ExTriple (MapFRW m n f) -> FR m n f -> FR m n f+wrapFRewrite3 map frw = uncurry3 mkFRewrite3 $ apply map $ getFRewrite3 frw -shallowBwdRw :: SimpleBwdRewrite n f -> BwdRewrite n f-shallowBwdRw rw n f = case (rw n f) of-                         Nothing -> Nothing-                         Just ag -> Just (BwdRes ag noBwdRewrite)+wrapFRewrites23 :: ExTriple (MapFRW2 m n f) -> FR m n f -> FR m n f -> FR m n f+wrapFRewrites23 map frw1 frw2 =+  uncurry3 mkFRewrite3 $ (applyBinary map `on` getFRewrite3) frw1 frw2 -deepBwdRw :: SimpleBwdRewrite n f -> BwdRewrite n f-deepBwdRw r = iterBwdRw (shallowBwdRw r) +-- Combinators for higher-rank rewriting functions:+wrapSFRewrites' :: (forall e x . LiftFRW m n f e x) -> SimpleFwdRewrite3 m n f -> FR m n f+wrapSFRewrites' lift = wrapSFRewrite3 (lift, lift, lift) -thenBwdRw :: BwdRewrite n f -> BwdRewrite n f -> BwdRewrite n f-thenBwdRw rw1 rw2 n f-  = case rw1 n f of-      Nothing               -> rw2 n f-      Just (BwdRes ag rw1a) -> Just (BwdRes ag (rw1a `thenBwdRw` rw2))+wrapFRewrites :: (forall e x . MapFRW m n f e x) -> FR m n f -> FR m n f+wrapFRewrites map = wrapFRewrite3 (map, map, map)+-- It's ugly that we can't use+--    wrapFRewrites' = mkFRewrite'+-- Would be nice to refactor here XXX  ---NR -iterBwdRw :: BwdRewrite n f -> BwdRewrite n f-iterBwdRw rw =-  \ n f -> case rw n f of-             Just (BwdRes g rw2) -> Just $ BwdRes g (rw2 `thenBwdRw` iterBwdRw rw)-             Nothing             -> Nothing -{--productFwd :: FwdPass n f -> FwdPass n f' -> FwdPass n (f, f')-productFwd pass pass' = FwdPass lattice transfer rewrite-    where -- can't tell if I have a FactBase of pairs or a pair of facts-          transfer n fb = (fp_transfer pass  $ factBaseMap fst fb,-                           fp_transfer pass' $ factBaseMap snd fb)-          transfer n (f, f') = (fp_transfer pass f, fp_transfer pass' f')-             ...              +wrapFRewrites2 :: (forall e x . MapFRW2 m n f e x) -> FR m n f -> FR m n f -> FR m n f+wrapFRewrites2 map = wrapFRewrites23 (map, map, map) --}+----------------------------------------------------------------+++shallowFwdRw3 :: forall m n f . Monad m => SimpleFwdRewrite3 m n f -> FwdRewrite m n f+shallowFwdRw3 rw = wrapSFRewrites' lift rw+  where lift rw n f = liftM (liftM (flip FwdRew noFwdRewrite)) (rw n f) ++shallowFwdRw :: Monad m => SimpleFwdRewrite m n f -> FwdRewrite m n f+shallowFwdRw f = shallowFwdRw3 (f, f, f)++deepFwdRw3    :: Monad m => SimpleFwdRewrite3 m n f -> FwdRewrite m n f+deepFwdRw :: Monad m => SimpleFwdRewrite m n f -> FwdRewrite m n f+deepFwdRw3    r = iterFwdRw (shallowFwdRw3 r)+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' = wrapFRewrites2 thenrw rw3 rw3'+ where+  thenrw rw rw' n f = rw n f >>= fwdRes+     where fwdRes Nothing = rw' n f+           fwdRes (Just (FwdRew g rw3a))+            = return $ Just $ FwdRew g (rw3a `thenFwdRw` rw3')++noFwdRewrite :: Monad m => FwdRewrite m n f+noFwdRewrite = mkFRewrite $ \ _ _ -> return Nothing++-- @ start iterf.tex+iterFwdRw :: Monad m +          => FwdRewrite m n f +          -> FwdRewrite m n f+-- @ end iterf.tex+iterFwdRw rw3 = wrapFRewrites iter rw3+ where+    iter rw n f = liftM (liftM fwdRes) (rw n f)+    fwdRes (FwdRew g rw3a) = +      FwdRew g (rw3a `thenFwdRw` iterFwdRw rw3)++----------------------------------------------------------------+type BwdRes m n f e x = Maybe (BwdRew m n f e x)++type SBRW m n f e x = n e x -> Fact x f -> m (Maybe (Graph n e x))+type BRW  m n f e x = n e x -> Fact x f -> m (BwdRes m n f e x)+type SimpleBwdRewrite3 m n f = ExTriple ( SBRW m n f)+type SimpleBwdRewrite m n f = forall e x . SBRW m n f e x+type LiftBRW m n f e x = SBRW m n f e x -> BRW m n f e x+type MapBRW  m n f e x = BRW  m n f e x -> BRW m n f e x+type MapBRW2 m n f e x = BRW  m n f e x -> BRW m n f e x -> BRW m n f e x++----------------------------------------------------------------++wrapSBRewrite3 :: ExTriple (LiftBRW m n f) -> SimpleBwdRewrite3 m n f -> BwdRewrite m n f+wrapSBRewrite3 lift rw = uncurry3 mkBRewrite3 $ apply lift rw++wrapBRewrite3 :: ExTriple (MapBRW m n f) -> BwdRewrite m n f -> BwdRewrite m n f+wrapBRewrite3 map rw = uncurry3 mkBRewrite3 $ apply map $ getBRewrite3 rw++wrapBRewrites2 :: ExTriple (MapBRW2 m n f) -> BR m n f -> BR m n f -> BR m n f+wrapBRewrites2 map rw1 rw2 =+  uncurry3 mkBRewrite3 $ (applyBinary map `on` getBRewrite3) rw1 rw2++-- Combinators for higher-rank rewriting functions:+wrapSBRewrites' :: (forall e x . LiftBRW m n f e x) -> SimpleBwdRewrite3 m n f -> BR m n f+wrapSBRewrites' lift = wrapSBRewrite3 (lift, lift, lift)++wrapBRewrites' :: (forall e x . MapBRW m n f e x) -> BwdRewrite m n f -> BwdRewrite m n f+wrapBRewrites' map = wrapBRewrite3 (map, map, map)++wrapBRewrites2' :: (forall e x . MapBRW2 m n f e x) -> BR m n f -> BR m n f -> BR m n f+wrapBRewrites2' map = wrapBRewrites2 (map, map, map)++----------------------------------------------------------------++noBwdRewrite :: Monad m => BwdRewrite m n f+noBwdRewrite = mkBRewrite $ \ _ _ -> return Nothing++shallowBwdRw3 :: Monad m => SimpleBwdRewrite3 m n f -> BwdRewrite m n f+shallowBwdRw3 rw = wrapSBRewrites' lift rw+  where lift rw n f = liftM (liftM (flip BwdRew noBwdRewrite)) (rw n f)++shallowBwdRw :: Monad m => SimpleBwdRewrite m n f -> BwdRewrite m n f+shallowBwdRw f = shallowBwdRw3 (f, f, f)++deepBwdRw3 :: Monad m => SimpleBwdRewrite3 m n f -> BwdRewrite m n f+deepBwdRw  :: Monad m => SimpleBwdRewrite  m n f -> BwdRewrite m n f+deepBwdRw3 r = iterBwdRw (shallowBwdRw3 r)+deepBwdRw  f = deepBwdRw3 (f, f, f)+++thenBwdRw :: Monad m => BwdRewrite m n f -> BwdRewrite m n f -> BwdRewrite m n f+thenBwdRw rw1 rw2 = wrapBRewrites2' f rw1 rw2+  where f rw1 rw2' n f = do+          res1 <- rw1 n f+          case res1 of+            Nothing              -> rw2' n f+            Just (BwdRew g rw1a) -> return $ Just $ BwdRew g (rw1a `thenBwdRw` rw2)++iterBwdRw :: Monad m => BwdRewrite m n f -> BwdRewrite m n f+iterBwdRw rw = wrapBRewrites' f rw+  where f rw' n f = liftM (liftM iterRewrite) (rw' n f)+        iterRewrite (BwdRew g rw2) = BwdRew g (rw2 `thenBwdRw` iterBwdRw rw)++-- @ start pairf.tex+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 = liftRW (fp_rewrite pass1) fst `thenFwdRw` liftRW (fp_rewrite pass2) snd+      where+        liftRW rws proj = mkFRewrite3 (lift f) (lift m) (lift l)+          where lift rw n f = liftM (liftM projRewrite) $ rw n (proj f)+                projRewrite (FwdRew g rws') = FwdRew g $ liftRW rws' proj+                (f, m, l) = getFRewrite3 rws++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 = liftRW (bp_rewrite pass1) fst `thenBwdRw` liftRW (bp_rewrite pass2) snd+      where+        liftRW :: forall f1 . BwdRewrite m n f1 -> ((f, f') -> f1) -> BwdRewrite m n (f, f')+        liftRW rws proj = mkBRewrite3 (lift proj f) (lift proj m) (lift (mapMap proj) l)+          where lift proj' rw n f = liftM (liftM projRewrite) $ rw n (proj' f)+                projRewrite (BwdRew g rws') = BwdRew g $ liftRW rws' proj+                (f, m, l) = getBRewrite3 rws++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,76 +1,24 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- bug in GHC--{- Notes about the genesis of Hoopl7-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Hoopl7 has the following major chages--a) GMany has symmetric entry and exit-b) GMany closed-entry does not record a BlockId-c) GMany open-exit does not record a BlockId-d) The body of a GMany is called Body-e) A Body is just a list of blocks, not a map. I've argued-   elsewhere that this is consistent with (c)--A consequence is that Graph is no longer an instance of Edges,-but nevertheless I managed to keep the ARF and ARB signatures-nice and uniform.--This was made possible by--* FwdTransfer looks like this:-    type FwdTransfer n f-      = forall e x. n e x -> Fact e f -> Fact x f -    type family   Fact x f :: *-    type instance Fact C f = FactBase f-    type instance Fact O f = f--  Note that the incoming fact is a Fact (not just 'f' as in Hoopl5,6).-  It's up to the *transfer function* to look up the appropriate fact-  in the FactBase for a closed-entry node.  Example:-	constProp (Label l) fb = lookupFact fb l-  That is how Hoopl can avoid having to know the block-id for the-  first node: it defers to the client.--  [Side note: that means the client must know about -  bottom, in case the looupFact returns Nothing]--* Note also that FwdTransfer *returns* a Fact too;-  that is, the types in both directions are symmetrical.-  Previously we returned a [(BlockId,f)] but I could not see-  how to make everything line up if we do this.--  Indeed, the main shortcoming of Hoopl7 is that we are more-  or less forced into this uniform representation of the facts-  flowing into or out of a closed node/block/graph, whereas-  previously we had more flexibility.--  In exchange the code is neater, with fewer distinct types.-  And morally a FactBase is equivalent to [(BlockId,f)] and-  nearly equivalent to (BlockId -> f).--* I've realised that forwardBlockList and backwardBlockList-  both need (Edges n), and that goes everywhere.--* I renamed BlockId to Label--}+{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-} -module Compiler.Hoopl.Dataflow -  ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..)+module Compiler.Hoopl.Dataflow+  ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact   , ChangeFlag(..), changeIf-  , FwdPass(..),  FwdTransfer, FwdRewrite, FwdRes(..)-  , BwdPass(..), BwdTransfer, BwdRewrite, BwdRes(..)-  , Fact+  , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3+  , FwdRew(..),  FwdRewrite,  mkFRewrite,  mkFRewrite3,  getFRewrite3+  , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3+  , BwdRew(..),  BwdRewrite,  mkBRewrite,  mkBRewrite3,  getBRewrite3   , analyzeAndRewriteFwd,  analyzeAndRewriteBwd-  , analyzeAndRewriteFwd', analyzeAndRewriteBwd'   ) where +import Data.Maybe++import Compiler.Hoopl.Collections import Compiler.Hoopl.Fuel-import Compiler.Hoopl.Graph+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.MkGraph (AGraph, graphOfAGraph) import Compiler.Hoopl.Util  -----------------------------------------------------------------------------@@ -80,10 +28,13 @@ data DataflowLattice a = DataflowLattice    { fact_name       :: String          -- Documentation  , fact_bot        :: a               -- Lattice bottom element- , fact_extend     :: JoinFun a       -- Lattice join plus change flag+ , fact_join       :: JoinFun a       -- Lattice join plus change flag                                       -- (changes iff result > old fact)- , fact_do_logging :: Bool            -- log changes  }+-- ^ 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@@ -98,43 +49,63 @@ --		Analyze and rewrite forward: the interface ----------------------------------------------------------------------------- -data FwdPass n f+data FwdPass m n f   = FwdPass { fp_lattice  :: DataflowLattice f             , fp_transfer :: FwdTransfer n f-            , fp_rewrite  :: FwdRewrite n f }+            , fp_rewrite  :: FwdRewrite m n f } -type FwdTransfer n f -  = forall e x. n e x -> Fact e f -> Fact x f +newtype FwdTransfer n f +  = FwdTransfer3 { getFTransfer3 ::+                     ( n C O -> f -> f+                     , n O O -> f -> f+                     , n O C -> f -> FactBase f+                     ) } -type FwdRewrite n f -  = forall e x. n e x -> Fact e f -> Maybe (FwdRes n f e x)-data FwdRes n f e x = FwdRes (AGraph n e x) (FwdRewrite n f)+newtype FwdRewrite m n f +  = FwdRewrite3 { getFRewrite3 ::+                    ( n C O -> f -> m (Maybe (FwdRew m n f C O))+                    , n O O -> f -> m (Maybe (FwdRew m n f O O))+                    , n O C -> f -> m (Maybe (FwdRew m n f O C))+                    ) }+data FwdRew m n f e x = FwdRew (Graph n e x) (FwdRewrite m n f)+   -- result of a rewrite is a new graph and a (possibly) new rewrite function +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)++mkFRewrite3 :: (n C O -> f -> m (Maybe (FwdRew m n f C O)))+            -> (n O O -> f -> m (Maybe (FwdRew m n f O O)))+            -> (n O C -> f -> m (Maybe (FwdRew m n f O C)))+            -> FwdRewrite m n f+mkFRewrite3 f m l = FwdRewrite3 (f, m, l)++mkFRewrite :: (forall e x . n e x -> f -> m (Maybe (FwdRew m n f e x)))+           -> FwdRewrite m n f+mkFRewrite f = FwdRewrite3 (f, f, f)++ type family   Fact x f :: * type instance Fact C f = FactBase f type instance Fact O f = f -analyzeAndRewriteFwd-   :: forall n f. Edges n-   => FwdPass n f-   -> Body n -> FactBase f-   -> FuelMonad (Body n, FactBase f)--analyzeAndRewriteFwd pass body facts-  = do { (rg, _) <- arfBody pass body facts-       ; return (normaliseBody rg) }- -- | if the graph being analyzed is open at the entry, there must --   be no other entry point, or all goes horribly wrong...-analyzeAndRewriteFwd'-   :: forall n f e x. Edges n-   => FwdPass n f+analyzeAndRewriteFwd+   :: forall m n f e x entries. (FuelMonad m, NonLocal n, LabelsPtr entries)+   => FwdPass m n f+   -> MaybeC e entries    -> Graph n e x -> Fact e f-   -> FuelMonad (Graph n e x, FactBase f, MaybeO x f)-analyzeAndRewriteFwd' pass g f =-  do (rg, fout) <- arfGraph pass g f-     let (g', fb) = normalizeGraph g rg+   -> 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@@ -145,166 +116,250 @@           maybe (GMany _ _ x) = case x of NothingO -> NothingO                                           JustO _  -> JustO f -normalizeGraph :: Edges n => Graph n e x -> RG n f e x -> GraphWithFacts n f e x-normalizeGraph GNil = normOO-normalizeGraph (GUnit {}) = normOO-normalizeGraph (GMany NothingO  _ NothingO)  = normCC-normalizeGraph (GMany (JustO _) _ NothingO)  = normOC-normalizeGraph (GMany NothingO  _ (JustO _)) = normCO-normalizeGraph (GMany (JustO _) _ (JustO _)) = normOO-- ---------------------------------------------------------------- --       Forward Implementation ---------------------------------------------------------------- +type Entries e = MaybeC e [Label] -type ARF thing n -  = forall f e x. FwdPass n f -> thing e x -               -> Fact e f -> FuelMonad (RG n f e x, Fact x f)+arfGraph :: forall m n f e x .+            (NonLocal n, FuelMonad 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)+    block :: forall e x . Block n e x -> f        -> m (DG f n e x, Fact x f)+    node  :: forall e x . (ShapeLifter e x) +                       => n e x       -> f        -> m (DG f n e x, Fact x f)+-- @ 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'+    cat :: forall m e a x info info' info''. Monad m =>+           (info  -> m (DG f n e a, info'))+        -> (info' -> m (DG f n a x, info''))+        -> (info  -> m (DG f n e x, info'')) -arfNode :: Edges n => ARF n n-arfNode pass node f-  = do { mb_g <- withFuel (fp_rewrite pass node f)-       ; case mb_g of-           Nothing -> return (RGUnit f (BUnit node),-                              fp_transfer pass node f)-      	   Just (FwdRes ag rw) -> do { g <- graphOfAGraph ag-                                     ; let pass' = pass { fp_rewrite = rw }-                                     ; arfGraph pass' g f } }+    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" -arfBlock :: Edges n => ARF (Block n) n--- Lift from nodes to blocks-arfBlock pass (BUnit node)   f = arfNode pass node f-arfBlock pass (BCat hd mids) f = do { (g1,f1) <- arfBlock pass hd   f  -                                    ; (g2,f2) <- arfBlock pass mids f1 -	                            ; return (g1 `RGCatO` g2, f2) }+    -- 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 -arfBody :: Edges n-        => FwdPass n f -> Body n -> FactBase f-        -> FuelMonad (RG n f C C, FactBase f)-		-- Outgoing factbase is restricted to Labels *not* in-		-- in the Body; the facts for Labels *in*-                -- the Body are in the BodyWithFacts-arfBody pass blocks init_fbase-  = fixpoint True (fp_lattice pass) (arfBlock pass) init_fbase $-    forwardBlockList (factBaseLabels init_fbase) blocks+    node n f+      = do { fwdres <- withFuel =<< frewrite pass n f+           ; case fwdres of+               Nothing -> return (toDg f (toBlock n),+                                  ftransfer pass n f)+               Just (FwdRew g rw) ->+                   let pass' = pass { fp_rewrite = rw }+                   in  arfGraph pass' (maybeEntry n) g (fwdEntryFact n f) } -arfGraph :: Edges n => ARF (Graph n) n--- Lift from blocks to graphs-arfGraph _    GNil        f = return (RGNil, f)-arfGraph pass (GUnit blk) f = arfBlock pass blk f-arfGraph pass (GMany NothingO body NothingO) f-  = do { (body', fb) <- arfBody pass body f-       ; return (body', fb) }-arfGraph pass (GMany NothingO body (JustO exit)) f-  = do { (body', fb) <- arfBody  pass body f-       ; (exit', fx) <- arfBlock pass exit fb-       ; return (body' `RGCatC` exit', fx) }-arfGraph pass (GMany (JustO entry) body NothingO) f-  = do { (entry', fe) <- arfBlock pass entry f-       ; (body', fb)  <- arfBody  pass body fe-       ; return (entry' `RGCatC` body', fb) }-arfGraph pass (GMany (JustO entry) body (JustO exit)) f-  = do { (entry', fe) <- arfBlock pass entry f-       ; (body', fb)  <- arfBody  pass body fe-       ; (exit', fx)  <- arfBlock pass exit fb-       ; return (entry' `RGCatC` body' `RGCatC` exit', fx) }+    -- | Compose fact transformers and concatenate the resulting+    -- rewritten graphs.+    {-# INLINE cat #-} +    cat ft1 ft2 f = do { (g1,f1) <- ft1 f+                       ; (g2,f2) <- ft2 f1+                       ; return (g1 `dgSplice` g2, f2) } -forwardBlockList :: (Edges n, LabelsPtr entry)+    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 (DataflowLattice {fact_bot = bot, fact_join = fj}) fb =+  mkFactBase $ 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 (bodyMap blks) entries+forwardBlockList entries blks = postorder_dfs_from blks entries  ----------------------------------------------------------------------------- --		Backward analysis and rewriting: the interface ----------------------------------------------------------------------------- -data BwdPass n f+data BwdPass m n f   = BwdPass { bp_lattice  :: DataflowLattice f             , bp_transfer :: BwdTransfer n f-            , bp_rewrite  :: BwdRewrite n f }+            , bp_rewrite  :: BwdRewrite m n f } -type BwdTransfer n f -  = forall e x. n e x -> Fact x f -> Fact e f -type BwdRewrite n f -  = forall e x. n e x -> Fact x f -> Maybe (BwdRes n f e x)-data BwdRes n f e x = BwdRes (AGraph n e x) (BwdRewrite 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 (BwdRew m n f C O))+                    , n O O -> f          -> m (Maybe (BwdRew m n f O O))+                    , n O C -> FactBase f -> m (Maybe (BwdRew m n f O C))+                    ) }+data BwdRew m n f e x = BwdRew (Graph n e x) (BwdRewrite m n f) ++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)++mkBRewrite3 :: (n C O -> f          -> m (Maybe (BwdRew m n f C O)))+            -> (n O O -> f          -> m (Maybe (BwdRew m n f O O)))+            -> (n O C -> FactBase f -> m (Maybe (BwdRew m n f O C)))+            -> BwdRewrite m n f+mkBRewrite3 f m l = BwdRewrite3 (f, m, l)++mkBRewrite :: (forall e x . n e x -> Fact x f -> m (Maybe (BwdRew m n f e x)))+           -> BwdRewrite m n f+mkBRewrite f = BwdRewrite3 (f, f, f)++ ----------------------------------------------------------------------------- --		Backward implementation ----------------------------------------------------------------------------- -type ARB thing n -  = forall f e x. BwdPass n f -> thing e x-               -> Fact x f -> FuelMonad (RG n f e x, Fact e f)+arbGraph :: forall m n f e x .+            (NonLocal n, FuelMonad 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'')) -arbNode :: Edges n => ARB n n--- Lifts (BwdTransfer,BwdRewrite) to ARB_Node; --- this time we do rewriting as well. --- The ARB_Graph parameters specifies what to do with the rewritten graph-arbNode pass node f-  = do { mb_g <- withFuel (bp_rewrite pass node f)-       ; case mb_g of-           Nothing -> return (RGUnit entry_f (BUnit node), entry_f)-                    where-                      entry_f = bp_transfer pass node f-      	   Just (BwdRes ag rw) -> do { g <- graphOfAGraph ag-                                     ; let pass' = pass { bp_rewrite = rw }-                                     ; arbGraph pass' g f} }+    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" -arbBlock :: Edges n => ARB (Block n) n --- Lift from nodes to blocks-arbBlock pass (BUnit node) f = arbNode pass node f-arbBlock pass (BCat b1 b2) f = do { (g2,f2) <- arbBlock pass b2 f-                                  ; (g1,f1) <- arbBlock pass b1 f2-	                          ; return (g1 `RGCatO` g2, f1) }+    -- 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 -arbBody :: Edges n-        => BwdPass n f -> Body n -> FactBase f-        -> FuelMonad (RG n f C C, FactBase f)-arbBody pass blocks init_fbase-  = fixpoint False (bp_lattice pass) (arbBlock pass) init_fbase $-    backwardBlockList blocks +    node n f+      = do { bwdres <- withFuel =<< brewrite pass n f+           ; case bwdres of+               Nothing -> return (toDg entry_f (toBlock n), entry_f)+                            where entry_f = btransfer pass n f+               Just (BwdRew g rw) ->+                          do { let pass' = pass { bp_rewrite = rw }+                             ; (g, f) <- arbGraph pass' (maybeEntry n) g f+                             ; return (g, bwdEntryFact (bp_lattice pass) n f)} } -arbGraph :: Edges n => ARB (Graph n) n-arbGraph _    GNil        f = return (RGNil, f)-arbGraph pass (GUnit blk) f = arbBlock pass blk f-arbGraph pass (GMany NothingO body NothingO) f-  = do { (body', fb) <- arbBody pass body f-       ; return (body', fb) }-arbGraph pass (GMany NothingO body (JustO exit)) f-  = do { (exit', fx) <- arbBlock pass exit f-       ; (body', fb) <- arbBody  pass body fx-       ; return (body' `RGCatC` exit', fb) }-arbGraph pass (GMany (JustO entry) body NothingO) f-  = do { (body', fb)  <- arbBody  pass body f-       ; (entry', fe) <- arbBlock pass entry fb-       ; return (entry' `RGCatC` body', fe) }-arbGraph pass (GMany (JustO entry) body (JustO exit)) f-  = do { (exit', fx)  <- arbBlock pass exit f-       ; (body', fb)  <- arbBody  pass body fx-       ; (entry', fe) <- arbBlock pass entry fb-       ; return (entry' `RGCatC` body' `RGCatC` exit', fe) }+    -- | 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) } -backwardBlockList :: Edges n => Body n -> [Block n C C]+    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 body = reachable ++ missing-  where reachable = reverse $ forwardBlockList entries body-        entries = externalEntryLabels body-        all = bodyList body-        missingLabels =-            mkLabelSet (map fst all) `minusLabelSet`-            mkLabelSet (map entryLabel reachable)-        missing = map snd $ filter (flip elemLabelSet missingLabels . fst) all+backwardBlockList entries body = reverse $ forwardBlockList entries body  {- -The forward and backward dataflow analyses now use postorder depth-first-order for faster convergence.- 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@@ -315,45 +370,19 @@ reach the exit, as in a procedure that loops forever and has side effects.) -Since in the general case, no information is available about entry-points, I have put in a horrible hack.  First, I assume that every-label defined but not used is an entry point.  Then, because an entry-point might also be a loop header, I add, in arbitrary order, all the-remaining "missing" blocks.  Needless to say, I am not pleased.  -I am not satisfied.  I am not Senator Morgan.--Wait! I believe that the Right Thing here is to require that anyone-wishing to analyze a graph closed at the entry provide a way of-determining the entry points, if any, of that graph.  This requirement-can apply equally to forward and backward analyses; I believe that-using the input FactBase to determine the entry points of a closed-graph is *also* a hack.--NR- -}  -analyzeAndRewriteBwd-   :: forall n f. Edges n-   => BwdPass n f -   -> Body n -> FactBase f -   -> FuelMonad (Body n, FactBase f)--analyzeAndRewriteBwd pass body facts-  = do { (rg, _) <- arbBody pass body facts-       ; return (normaliseBody rg) }- -- | if the graph being analyzed is open at the exit, I don't --   quite understand the implications of possible other exits-analyzeAndRewriteBwd'-   :: forall n f e x. Edges n-   => BwdPass n f-   -> Graph n e x -> Fact x f-   -> FuelMonad (Graph n e x, FactBase f, MaybeO e f)-analyzeAndRewriteBwd' pass g f =-  do (rg, fout) <- arbGraph pass g f-     let (g', fb) = normalizeGraph g rg+analyzeAndRewriteBwd+   :: (FuelMonad 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@@ -364,95 +393,151 @@           maybe (GMany e _ _) = case e of NothingO -> NothingO                                           JustO _  -> JustO f - ----------------------------------------------------------------------------- --      fixpoint: finding fixed points ------------------------------------------------------------------------------ data TxFactBase n f   = TxFB { tfb_fbase :: FactBase f-         , tfb_rg  :: RG n f C C -- Transformed blocks+         , tfb_rg    :: DG f n C C -- Transformed blocks          , tfb_cha   :: ChangeFlag          , tfb_lbls  :: LabelSet }- -- Note [TxFactBase change flag]- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- Set the tfb_cha flag iff - --   (a) the fact in tfb_fbase for or a block L changes- --   (b) L is in tfb_lbls.- -- The tfb_lbls are all Labels of the *original* - -- (not transformed) blocks+     -- See Note [TxFactBase invariants] -updateFact :: DataflowLattice f -> LabelSet -> (Label, f)-           -> (ChangeFlag, FactBase f) +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 `elemLabelSet` lbls = (SomeChange, new_fbase)-  | otherwise               = (cha,        new_fbase)+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 fbase lbl of-           Nothing -> (SomeChange, snd $ join $ fact_bot lat)  -- 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_extend lat lbl (OldFact old_fact) (NewFact new_fact)-    new_fbase = extendFactBase fbase lbl res_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 -fixpoint :: forall n f. Edges n-         => Bool	-- Going forwards?+{-  this type is too general for the paper :-( +fixpoint :: forall m block n f. +            (FuelMonad m, NonLocal n, NonLocal (block n))+         => Direction          -> DataflowLattice f-         -> (Block n C C -> FactBase f-              -> FuelMonad (RG n f C C, FactBase f))+         -> (block n C C -> FactBase f+             -> m (DG f n C C, [(Label, f)]))+         -> [block n C C]          -> FactBase f -         -> [Block n C C]-         -> FuelMonad (RG n f C C, FactBase f)-fixpoint is_fwd lat do_block init_fbase untagged_blocks+         -> m (DG f n C C, FactBase f)+-}+-- @ start fptype.tex+data Direction = Fwd | Bwd+fixpoint :: forall m n f. (FuelMonad m, NonLocal n)+ => Direction+ -> DataflowLattice f+ -> (Block n C C -> Fact C f -> m (DG f n C C, Fact C f))+ -> [Block n C C]+ -> (Fact C f -> m (DG f n C C, Fact C f))+-- @ end fptype.tex+fixpoint direction lat do_block blocks init_fbase   = do { fuel <- getFuel          ; tx_fb <- loop fuel init_fbase        ; return (tfb_rg tx_fb, -                 tfb_fbase tx_fb `delFromFactBase` map fst blocks) }+                 map (fst . fst) tagged_blocks +                    `mapDeleteList` tfb_fbase tx_fb ) } 	     -- The successors of the Graph are the the Labels for which 	     -- we have facts, that are *not* in the blocks of the graph   where-    blocks = map tag untagged_blocks-     where tag b = ((entryLabel b, b), if is_fwd then [entryLabel b] else successors b)+    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 -> FuelMonad (TxFactBase n f)+              -> TxFactBase n f -> m (TxFactBase n f)     tx_blocks []              tx_fb = return tx_fb-    tx_blocks (((lbl,blk), deps):bs) tx_fb = tx_block lbl blk deps tx_fb >>= tx_blocks bs-     -- "deps" == Labels the block may _depend_ upon for facts+    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 -> FuelMonad (TxFactBase n f)-    tx_block lbl blk deps tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls-                                      , tfb_rg = blks, tfb_cha = cha })-      | is_fwd && not (lbl `elemFactBase` fbase)-      = return tx_fb {tfb_lbls = lbls `unionLabelSet` mkLabelSet deps}	-- Note [Unreachable blocks]+             -> 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') -                   = foldr (updateFact lat lbls) (cha,fbase) -                           (factBaseList out_facts)-                 lbls' = lbls `unionLabelSet` mkLabelSet deps+                   = mapFoldWithKey (updateFact lat lbls) +                          (cha,fbase) out_facts            ; return (TxFB { tfb_lbls  = lbls'-                          , tfb_rg    = rg `RGCatC` blks-                          , tfb_fbase = fbase', tfb_cha = cha' }) }+                          , tfb_rg    = rg `dgSplice` blks+                          , tfb_fbase = fbase'+                          , tfb_cha = cha' }) }+      where+        lbls' = lbls `setUnion` setFromList in_lbls+         -    loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f)+    loop :: Fuel -> FactBase f -> m (TxFactBase n f)     loop fuel fbase -      = do { let init_tx_fb = TxFB { tfb_fbase = fbase-                                   , tfb_cha   = NoChange-                                   , tfb_rg    = RGNil-                                   , tfb_lbls  = emptyLabelSet }-           ; tx_fb <- tx_blocks blocks init_tx_fb+      = do { 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 { setFuel fuel-                                ; loop fuel (tfb_fbase tx_fb) } }+               SomeChange +                 -> do { setFuel fuel+                       ; loop fuel (tfb_fbase tx_fb) } } -{- Note [Unreachable blocks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{-  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:@@ -477,7 +562,7 @@        the points above bottom  * Even if the fact is going from UNR to bottom, we still call the-  client's fact_extend function because it might give the client+  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@@ -486,61 +571,115 @@ -}  --------------------------------------------------------------------------------	RG: an internal data type for graphs under construction---          TOTALLY internal to Hoopl+--	DG: an internal data type for 'decorated graphs'+--          TOTALLY internal to Hoopl; each block is decorated with a fact ----------------------------------------------------------------------------- --- this type exists because we have not yet found a way to write arfNode--- to return a Graph; the invariants of Graph seem too strong+-- @ 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+toDg :: NonLocal n => f -> Block n e x -> DG f n e x+-- @ end dg.tex+instance NonLocal n => NonLocal (DBlock f n) where+  entryLabel (DBlock _ b) = entryLabel b+  successors (DBlock _ b) = successors b -data RG n f e x where-  RGNil   :: RG n f a a-  RGUnit  :: Fact e f -> Block n e x -> RG n f e x-  RGCatO  :: RG n f e O -> RG n f O x -> RG n f e x-  RGCatC  :: RG n f e C -> RG n f C x -> RG n f e x+--- constructors -type BodyWithFacts  n f     = (Body n, FactBase f)+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 -normaliseBody :: Edges n => RG n f C C -> BodyWithFacts n f-normaliseBody rg = (body, fact_base)-  where-    (GMany _ body _, fact_base) = normCC rg+normalizeGraph :: forall n f e x .+                  NonLocal n => DG f n e x -> GraphWithFacts n f e x -normOO :: Edges n => RG n f O O -> GraphWithFacts n f O O-normOO RGNil          = (GNil, noFacts)-normOO (RGUnit _ b)   = (GUnit b, noFacts)-normOO (RGCatO g1 g2) = normOO g1 `gwfCat` normOO g2-normOO (RGCatC g1 g2) = normOC g1 `gwfCat` normCO g2+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 -normOC :: Edges n => RG n f O C -> GraphWithFacts n f O C-normOC (RGUnit _ b)   = (GMany (JustO b) BodyEmpty NothingO, noFacts)-normOC (RGCatO g1 g2) = normOO g1 `gwfCat` normOC g2-normOC (RGCatC g1 g2) = normOC g1 `gwfCat` normCC g2+--- implementation of the constructors (boring) -normCO :: Edges n => RG n f C O -> GraphWithFacts n f C O-normCO (RGUnit f b) = (GMany NothingO BodyEmpty (JustO b), unitFact l f)-                    where-                      l = entryLabel b-normCO (RGCatO g1 g2) = normCO g1 `gwfCat` normOO g2-normCO (RGCatC g1 g2) = normCC g1 `gwfCat` normCO g2+dgnil  = GNil+dgnilC = GMany NothingO emptyBody NothingO -normCC :: Edges n => RG n f C C -> GraphWithFacts n f C C-normCC RGNil        = (GMany NothingO BodyEmpty NothingO, noFacts)-normCC (RGUnit f b) = (GMany NothingO (BodyUnit b) NothingO, unitFact l f)-                    where-                      l = entryLabel b-normCC (RGCatO g1 g2) = normCO g1 `gwfCat` normOC g2-normCC (RGCatC g1 g2) = normCC g1 `gwfCat` normCC g2+toDg f b@(BFirst  {}) = gUnitCO (DBlock f b)+toDg f b@(BMiddle {}) = gUnitOO (DBlock f b)+toDg f b@(BLast   {}) = gUnitOC (DBlock f b)+toDg f b@(BCat {})    = gUnitOO (DBlock f b)+toDg f b@(BHead {})   = gUnitCO (DBlock f b)+toDg f b@(BTail {})   = gUnitOC (DBlock f b)+toDg f b@(BClosed {}) = gUnitCC (DBlock f b) -gwfCat :: Edges n => GraphWithFacts n f e a-                  -> GraphWithFacts n f a x -                  -> GraphWithFacts n f e x-gwfCat (g1, fb1) (g2, fb2) = (g1 `U.gSplice` g2, fb1 `unionFactBase` fb2)+dgSplice = U.splice fzCat+  where fzCat (DBlock f b1) (DBlock _ b2) = DBlock f (b1 `U.cat` b2) -{--bwfUnion :: BodyWithFacts n f -> BodyWithFacts n f -> BodyWithFacts n f-bwfUnion (bg1, fb1) (bg2, fb2) = (bg1 `BodyCat` bg2, fb1 `unionFactBase` fb2)--}+----------------------------------------------------------------+--       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.+class ShapeLifter e x where+  toBlock      :: n e x -> Block n e x+  fwdEntryFact :: NonLocal n =>                      n e x -> f -> Fact e f+  bwdEntryFact :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f+  ftransfer    :: FwdPass m n f -> n e x -> f        -> Fact x f+  btransfer    :: BwdPass m n f -> n e x -> Fact x f -> f+  frewrite     :: FwdPass m n f -> n e x -> f        -> m (Maybe (FwdRew m n f e x))+  brewrite     :: BwdPass m n f -> n e x -> Fact x f -> m (Maybe (BwdRew m n f e x))+  maybeEntry   :: NonLocal n => n e x -> Entries e++instance ShapeLifter C O where+  toBlock         = BFirst+  fwdEntryFact     n f  = mkFactBase [(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+  maybeEntry n = JustC [entryLabel n]++instance ShapeLifter O O where+  toBlock      = 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+  maybeEntry _ = NothingC++instance ShapeLifter O C where+  toBlock      = 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+  maybeEntry _ = 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

@@ -2,10 +2,12 @@  module Compiler.Hoopl.Debug    ( TraceFn , debugFwdJoins , debugBwdJoins+  , debugFwdTransfers , debugBwdTransfers   ) where  import Compiler.Hoopl.Dataflow+import Compiler.Hoopl.Show  -------------------------------------------------------------------------------- -- | Debugging combinators:@@ -20,11 +22,28 @@ --   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 n f . Show f => TraceFn -> ChangePred -> FwdPass n f -> FwdPass n f-debugBwdJoins :: forall n f . Show f => TraceFn -> ChangePred -> BwdPass n f -> BwdPass n f+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@@ -33,13 +52,13 @@ debugBwdJoins trace pred p = p { bp_lattice = debugJoins trace pred $ bp_lattice p }  debugJoins :: Show f => TraceFn -> ChangePred -> DataflowLattice f -> DataflowLattice f-debugJoins trace showOutput l@(DataflowLattice {fact_extend = extend}) = l {fact_extend = extend'}+debugJoins trace showPred l@(DataflowLattice {fact_join = join}) = l {fact_join = join'}   where-   extend' l f1@(OldFact of1) f2@(NewFact nf2) =-     if showOutput c then trace output res else res-       where res@(c, f') = extend l f1 f2+   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 ++ " |_| "+                        SomeChange -> "+ Join@" ++ show l ++ ": " ++ show of1 ++ " `join` "                                                                   ++ show nf2 ++ " = " ++ show f'                         NoChange   -> "_ Join@" ++ show l ++ ": " ++ show nf2 ++ " <= " ++ show of1 @@ -47,9 +66,38 @@ -- Functions we'd like to have, but don't know how to implement generically: -------------------------------------------------------------------------------- --- type Showing n = forall e x . n e x -> String+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 n f . Show f => TraceFn -> Showing n -> FwdPass n f -> FwdPass n f+--   forall m n f . Show f => TraceFn -> ShowN n -> FwdPass m n f -> FwdPass m n f -- debugBwdTransfers, debugBwdRewrites, debugBwdAll ::---   forall n f . Show f => TraceFn -> Showing n -> BwdPass n f -> BwdPass n f+--   forall m n f . Show f => TraceFn -> ShowN n -> BwdPass m n f -> BwdPass m n f 

@@ -3,38 +3,87 @@ -----------------------------------------------------------------------------  module Compiler.Hoopl.Fuel-  ( Fuel-  , FuelMonad, withFuel, getFuel, setFuel-  , freshLabel-    -  , runWithFuel+  ( Fuel, infiniteFuel, fuelRemaining+  , withFuel+  , FuelMonad(..)+  , FuelMonadT(..)+  , CheckingFuelMonad+  , InfiniteFuelMonad+  , SimpleFuelMonad   ) where -import Compiler.Hoopl.Label+import Compiler.Hoopl.Unique -type Fuel    = Int+class Monad m => FuelMonad m where+  getFuel :: m Fuel+  setFuel :: Fuel -> m () -newtype FuelMonad a = FM { unFM :: Fuel -> [Label] -> (a, Fuel, [Label]) }+-- | Find out how much fuel remains after a computation.+-- Can be subtracted from initial fuel to get total consumption.+fuelRemaining :: FuelMonad m => m Fuel+fuelRemaining = getFuel -instance Monad FuelMonad where-  return x = FM (\f u -> (x,f,u))-  m >>= k  = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')+class FuelMonadT fm where+  runWithFuel :: (Monad m, FuelMonad (fm m)) => Fuel -> fm m a -> m a -withFuel :: Maybe a -> FuelMonad (Maybe a)++type Fuel = Int++withFuel :: FuelMonad m => Maybe a -> m (Maybe a) withFuel Nothing  = return Nothing-withFuel (Just r) = FM (\f u -> if f==0 then (Nothing, f, u)-                                else (Just r, f-1, u))+withFuel (Just a) = do f <- getFuel+                       if f == 0+                         then return Nothing+                         else setFuel (f-1) >> return (Just a) -getFuel :: FuelMonad Fuel-getFuel = FM (\f u -> (f,f,u)) -setFuel :: Fuel -> FuelMonad ()-setFuel f = FM (\_ u -> ((), f, u))+---------------------------------------------------------------- -runWithFuel :: Fuel -> FuelMonad a -> a-runWithFuel fuel m = a-  where (a, _, _) = unFM m fuel allLabels+newtype CheckingFuelMonad m a = FM { unFM :: Fuel -> m (a, Fuel) } -freshLabel :: FuelMonad Label-freshLabel = FM (\f (l:ls) -> (l, f, ls))+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 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 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

@@ -1,71 +1,114 @@-{-# LANGUAGE GADTs, EmptyDataDecls #-}+{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies #-}  module Compiler.Hoopl.Graph -  ( O, C, Block(..), Body, Body'(..), bodyMap, Graph, Graph'(..), MaybeO(..)-  , Edges(entryLabel, successors)-  , addBlock, bodyList+  ( O, C, Block(..), Body, Body'(..), Graph, Graph'(..)+  , MaybeO(..), MaybeC(..), EitherCO+  , NonLocal(entryLabel, successors)+  , emptyBody, addBlock, bodyList   ) where +import Compiler.Hoopl.Collections import Compiler.Hoopl.Label  ----------------------------------------------------------------------------- --		Graphs ----------------------------------------------------------------------------- -data O+-- | 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 --- Blocks are always non-empty+-- | 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-  BUnit :: n e x -> Block n e x-  BCat  :: Block n e O -> Block n O x -> Block n e x+  -- 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 -type Body = Body' Block-data Body' block n where-  BodyEmpty :: Body' block n-  BodyUnit  :: block n C C -> Body' block n-  BodyCat   :: Body' block n -> Body' block n -> Body' block n+  -- 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) -        -> Body' block n+        -> 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++-- | Either type indexed by closed/open using type families+type family   EitherCO e a b :: *+type instance EitherCO C a b = a+type instance EitherCO O a b = b+ instance Functor (MaybeO ex) where-  fmap f NothingO = NothingO+  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)+ --------------------------------class Edges thing where-  entryLabel :: thing C x -> Label-  successors :: thing e C -> [Label]+-- | 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 Edges n => Edges (Block n) where-  entryLabel (BUnit n) = entryLabel n-  entryLabel (b `BCat` _) = entryLabel b-  successors (BUnit n)   = successors n-  successors (BCat _ b)  = successors b+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  -------------------------------addBlock :: block n C C -> Body' block n -> Body' block n-addBlock b body = BodyUnit b `BodyCat` body--bodyList :: Edges (block n) => Body' block n -> [(Label,block n C C)]-bodyList body = go body []-  where-    go BodyEmpty       bs = bs-    go (BodyUnit b)    bs = (entryLabel b, b) : bs-    go (BodyCat b1 b2) bs = go b1 (go b2 bs)+emptyBody :: LabelMap (thing C C)+emptyBody = mapEmpty -bodyMap :: Edges (block n) => Body' block n -> LabelMap (block n C C)-bodyMap = mkFactBase . bodyList+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,23 +1,22 @@ {-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- bug in GHC  -- N.B. addBasicBlocks won't work on OO without a Node (branch/label) constraint  module Compiler.Hoopl.GraphUtil-  ( splice, gSplice, zSplice-  , zCat-  , bodyGraph+  ( splice, gSplice , cat , bodyGraph, bodyUnion+  , frontBiasBlock, backBiasBlock   )  where +import Compiler.Hoopl.Collections import Compiler.Hoopl.Graph-import Compiler.Hoopl.Zipper+import Compiler.Hoopl.Label  bodyGraph :: Body n -> Graph n C C bodyGraph b = GMany NothingO b NothingO -splice :: forall block n e a x .+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@@ -33,33 +32,93 @@          sp (GMany e bs (JustO x)) (GUnit b2) = GMany e bs (JustO (x `bcat` b2)) -        sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) bs2 x2)-          = GMany e1 (addBlock (x1 `bcat` e2) bs1 `BodyCat` bs2) x2+        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 bs1 NothingO) (GMany NothingO bs2 x2)-           = GMany e1 (bs1 `BodyCat` bs2) x2+        sp (GMany e1 b1 NothingO) (GMany NothingO b2 x2)+          = GMany e1 (b1 `bodyUnion` b2) x2 +        sp _ _ = error "bogus GADT match failure" -gSplice :: Graph  n e a -> Graph  n a x -> Graph  n e x-zSplice :: ZGraph n e a -> ZGraph n a x -> ZGraph n e x+bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a+bodyUnion = mapUnionWithKey nodups+  where nodups l _ _ = error $ "duplicate blocks with label " ++ show l -gSplice = splice BCat-zSplice = splice zCat+gSplice :: NonLocal n => Graph n e a -> Graph n a x -> Graph n e x+gSplice = splice cat -zCat :: ZBlock n e O -> ZBlock n O x -> ZBlock n e x-zCat b1@(ZFirst {})     (ZMiddle n)  = ZHead   b1 n-zCat b1@(ZFirst {})  b2@(ZLast{})    = ZClosed b1 b2-zCat b1@(ZFirst {})  b2@(ZTail{})    = ZClosed b1 b2-zCat b1@(ZFirst {})     (ZCat b2 b3) = (b1 `zCat` b2) `zCat` b3-zCat b1@(ZHead {})      (ZCat b2 b3) = (b1 `zCat` b2) `zCat` b3-zCat b1@(ZHead {})      (ZMiddle n)  = ZHead   b1 n-zCat b1@(ZHead {})   b2@(ZLast{})    = ZClosed b1 b2-zCat b1@(ZHead {})   b2@(ZTail{})    = ZClosed b1 b2-zCat    (ZMiddle n)  b2@(ZLast{})    = ZTail    n b2-zCat b1@(ZMiddle {}) b2@(ZCat{})     = ZCat    b1 b2-zCat    (ZMiddle n)  b2@(ZTail{})    = ZTail    n b2-zCat    (ZCat b1 b2) b3@(ZLast{})    = b1 `zCat` (b2 `zCat` b3)-zCat    (ZCat b1 b2) b3@(ZTail{})    = b1 `zCat` (b2 `zCat` b3)-zCat b1@(ZCat {})    b2@(ZCat{})     = ZCat    b1 b2+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,113 +1,107 @@+{-# LANGUAGE TypeFamilies #-} module Compiler.Hoopl.Label   ( Label-  , allLabels -- to be used only by the Fuel monad-  , LabelMap-  , FactBase, noFacts, mkFactBase, unitFact, lookupFact, extendFactBase-            , delFromFactBase, unionFactBase-            , elemFactBase, factBaseLabels, factBaseList-  , LabelSet, emptyLabelSet, extendLabelSet, reduceLabelSet-            , mkLabelSet, elemLabelSet, labelSetElems-            , minusLabelSet, unionLabelSet, interLabelSet, sizeLabelSet, +  , freshLabel+  , LabelSet, LabelMap+  , FactBase, noFacts, mkFactBase, lookupFact++  , uniqueToLbl -- MkGraph and GHC use only+  , lblToUnique -- GHC use only   )  where -import qualified Data.IntMap as M-import qualified Data.IntSet as S--newtype Label = Label { unLabel :: Int }-  deriving (Eq, Ord)--instance Show Label where-  show (Label n) = "L" ++ show n---allLabels :: [Label]-allLabels = map Label [1..]--type LabelMap a = M.IntMap a--+import Compiler.Hoopl.Collections+import Compiler.Hoopl.Unique  --------------------------------------------------------------------------------		Label, FactBase, LabelSet+--		Label ----------------------------------------------------------------------------- -------------------------type FactBase a = M.IntMap a--mapFst :: (a->b) -> (a, c) -> (b, c)-mapFst f (a, c) = (f a, c)+newtype Label = Label { lblToUnique :: Unique }+  deriving (Eq, Ord) -noFacts :: FactBase f-noFacts = M.empty+uniqueToLbl :: Unique -> Label+uniqueToLbl = Label -mkFactBase :: [(Label, f)] -> FactBase f-mkFactBase prs = M.fromList $ map (mapFst unLabel) prs+instance Show Label where+  show (Label n) = "L" ++ show n -unitFact :: Label -> FactBase f -> FactBase f--- Restrict a fact base to a single fact-unitFact (Label l) fb = case M.lookup l fb of-                  Just f  -> M.singleton l f-                  Nothing -> M.empty+freshLabel :: UniqueMonad m => m Label+freshLabel = freshUnique >>= return . uniqueToLbl -lookupFact :: FactBase f -> Label -> Maybe f-lookupFact env (Label blk_id) = M.lookup blk_id env+-----------------------------------------------------------------------------+-- LabelSet -extendFactBase :: FactBase f -> Label -> f -> FactBase f-extendFactBase env (Label blk_id) f = M.insert blk_id f env+newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show) -unionFactBase :: FactBase f -> FactBase f -> FactBase f-unionFactBase = M.union+instance IsSet LabelSet where+  type ElemOf LabelSet = Label -elemFactBase :: Label -> FactBase f -> Bool-elemFactBase (Label l) = M.member l+  setNull (LS s) = setNull s+  setSize (LS s) = setSize s+  setMember (Label k) (LS s) = setMember k s -factBaseLabels :: FactBase f -> [Label]-factBaseLabels = map Label . M.keys+  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) -factBaseList :: FactBase f -> [(Label, f)]-factBaseList = map (mapFst Label) . M.toList +  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 -delFromFactBase :: FactBase f -> [(Label,a)] -> FactBase f-delFromFactBase fb blks = foldr (M.delete . unLabel . fst) fb blks+  setFold k z (LS s) = setFold (k . uniqueToLbl) z s ------------------------newtype LabelSet = LS { unLS :: S.IntSet }+  setElems (LS s) = map uniqueToLbl (setElems s)+  setFromList ks = LS (setFromList (map lblToUnique ks)) -emptyLabelSet :: LabelSet-emptyLabelSet = LS S.empty+-----------------------------------------------------------------------------+-- LabelMap -extendLabelSet :: LabelSet -> Label -> LabelSet-extendLabelSet lbls (Label bid) = LS $ S.insert bid $ unLS lbls+newtype LabelMap v = LM (UniqueMap v) deriving (Eq, Ord, Show) -reduceLabelSet :: LabelSet -> Label -> LabelSet-reduceLabelSet lbls (Label bid) = LS $ S.delete bid $ unLS lbls+instance IsMap LabelMap where+  type KeyOf LabelMap = Label -elemLabelSet :: Label -> LabelSet -> Bool-elemLabelSet (Label bid) lbls = S.member bid (unLS lbls)+  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 -labelSetElems :: LabelSet -> [Label]-labelSetElems = map Label . S.toList . unLS+  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) -set2 :: (S.IntSet -> S.IntSet -> S.IntSet)-     -> (LabelSet -> LabelSet -> LabelSet)-set2 f (LS ls) (LS ls') = LS (f ls ls')+  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 -minusLabelSet :: LabelSet -> LabelSet -> LabelSet-minusLabelSet = set2 S.difference+  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 -unionLabelSet :: LabelSet -> LabelSet -> LabelSet-unionLabelSet = set2 S.union+  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]) -interLabelSet :: LabelSet -> LabelSet -> LabelSet-interLabelSet = set2 S.intersection+-----------------------------------------------------------------------------+-- FactBase -sizeLabelSet :: LabelSet -> Int-sizeLabelSet = S.size . unLS+type FactBase f = LabelMap f -mkLabelSet :: [Label] -> LabelSet-mkLabelSet = LS . S.fromList . map unLabel+noFacts :: FactBase f+noFacts = mapEmpty +mkFactBase :: [(Label, f)] -> FactBase f+mkFactBase = mapFromList +lookupFact :: Label -> FactBase f -> Maybe f+lookupFact = mapLookup

@@ -1,8 +1,8 @@-{-# LANGUAGE ScopedTypeVariables, GADTs #-}+{-# LANGUAGE ScopedTypeVariables, GADTs, TypeSynonymInstances, FlexibleInstances, RankNTypes #-} module Compiler.Hoopl.MkGraph-    ( AGraph, graphOfAGraph-    , (<*>), (|*><*|), catAGraphs, addEntrySeq, addExitSeq, addBlocks, unionBlocks-    , emptyAGraph, emptyClosedAGraph, withFreshLabels+    ( AGraph, graphOfAGraph, aGraphOfGraph+    , (<*>), (|*><*|), catGraphs, addEntrySeq, addExitSeq, addBlocks, unionBlocks+    , emptyGraph, emptyClosedGraph, withFresh     , mkFirst, mkMiddle, mkMiddles, mkLast, mkBranch, mkLabel, mkWhileDo     , IfThenElseable(mkIfThenElse)     , mkEntry, mkExit@@ -10,24 +10,12 @@     ) where -import Compiler.Hoopl.Label (Label)+import Compiler.Hoopl.Label (Label, uniqueToLbl) import Compiler.Hoopl.Graph-import Compiler.Hoopl.Fuel import qualified Compiler.Hoopl.GraphUtil as U-+import Compiler.Hoopl.Unique import Control.Monad (liftM2) -newtype AGraph n e x = A { graphOfAGraph :: FuelMonad (Graph n e x) }--class Labels l where-  withFreshLabels :: (l -> AGraph n e x) -> AGraph n e x--emptyAGraph :: AGraph n O O-emptyAGraph = A $ return GNil--emptyClosedAGraph :: AGraph n C C-emptyClosedAGraph = A $ return $ GMany NothingO BodyEmpty NothingO- {-| As noted in the paper, we can define a single, polymorphic type of  splicing operation with the very polymorphic type@@ -36,200 +24,229 @@ @ 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 several operations:+thinking.  We therfore split it into two operations, '<*>' and '|*><*|', +which are supplemented by other functions:    * The '<*>' operator is true concatenation, for connecting open graphs.--  * The operators 'addEntrySeq' or 'addExitSeq' allow a client to add-    an entry or exit sequence to a graph that is closed at the entry or -    exit.--  * 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.-    (In GHC 6.12 this operator was called 'outOfLine'.)+    Control flows from the left graph to the right graph. -  * The operator 'unionBlocks' takes the union of two sets of basic blocks,-    each of which is represented as a closed/closed 'AGraph'.  It is not -    redundant with 'addBlocks', because 'addBlocks' requires a 'HooplNode'-    constraint but 'unionBlocks' does not.+  * 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 |*><*| splices two graphs at a closed point. 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. -There is some redundancy in this representation (any instance of-'addEntrySeq' is also an instance of either 'addExitSeq' or 'addBlocks'),-but because the different operators restrict polymorphism in different ways, -we felt some redundancy would be appropriate.- -}   -infixl 3 <*>-infixl 2 |*><*|-(<*>)    :: AGraph n e O -> AGraph n O x -> AGraph n e x-(|*><*|) :: AGraph n e C -> AGraph n C x -> AGraph n e x+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 -addEntrySeq    :: AGraph n O C -> AGraph n C x -> AGraph n O x-addExitSeq     :: AGraph n e C -> AGraph n C O -> AGraph n e O-addBlocks      :: HooplNode n-               => AGraph n e x -> AGraph n C C -> AGraph n e x-unionBlocks    :: AGraph n C C -> AGraph n C C -> AGraph n C C+  -- | 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') -addEntrySeq = liftA2 U.gSplice-addExitSeq  = liftA2 U.gSplice-unionBlocks = liftA2 U.gSplice-+-- | 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 :: HooplNode n => Graph n e x -> Graph n C C -> FuelMonad (Graph n e x)+  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 `BodyCat` body') x+          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 => Graph n O O -> Graph n C C -> FuelMonad(Graph n O O)-        spliceOO g blocks = graphOfAGraph $ withFreshLabels $ \l ->+        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 --mkFirst  :: n C O -> AGraph n C O-mkMiddle :: n O O -> AGraph n O O-mkLast   :: n O C -> AGraph n O C--mkLabel :: HooplNode n => Label -> AGraph n C O -- graph contains the label---- below for convenience-mkMiddles :: [n O O] -> AGraph n O O-mkEntry   :: Block n O C -> AGraph n O C-mkExit    :: Block n C O -> AGraph n C O--class Edges n => HooplNode n where+-- | 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 -mkBranch :: HooplNode n => Label -> AGraph n O C+--------------------------------------------------------------+--                   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-{--  fallThroughTo :: Node n-                => Label -> AGraph n e x -> AGraph n e C--}+               => (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 bloop-             -> AGraph n O O -- the final while loop---- ================================================================---                          IMPLEMENTATION--- ================================================================--(<*>)    = liftA2 U.gSplice -(|*><*|) = liftA2 U.gSplice -catAGraphs :: [AGraph n O O] -> AGraph n O O-catAGraphs = foldr (<*>) emptyAGraph------------------------------------------- constructors--mkLabel  id     = mkFirst $ mkLabelNode id-mkBranch target = mkLast  $ mkBranchNode target-mkMiddles ms = foldr (<*>) emptyAGraph (map mkMiddle ms)+             => (Label -> Label -> AGraph n O C) -- ^ loop condition+             -> AGraph n O O -- ^ body of the loop+             -> AGraph n O O -- ^ the final while loop  instance IfThenElseable O where-  mkIfThenElse cbranch tbranch fbranch = withFreshLabels $ \(endif, ltrue, lfalse) ->+  mkIfThenElse cbranch tbranch fbranch = withFresh $ \(endif, ltrue, lfalse) ->     cbranch ltrue lfalse |*><*|       mkLabel ltrue  <*> tbranch <*> mkBranch endif |*><*|       mkLabel lfalse <*> fbranch <*> mkBranch endif |*><*|       mkLabel endif -{--  fallThroughTo id g = g <*> mkBranch id--}- instance IfThenElseable C where-  mkIfThenElse cbranch tbranch fbranch = withFreshLabels $ \(ltrue, lfalse) ->+  mkIfThenElse cbranch tbranch fbranch = withFresh $ \(ltrue, lfalse) ->     cbranch ltrue lfalse |*><*|        mkLabel ltrue  <*> tbranch |*><*|        mkLabel lfalse <*> fbranch-{--  fallThroughTo _ g = g--} -mkWhileDo cbranch body = withFreshLabels $ \(test, head, endwhile) ->+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 ----------------------------------------- Debugging--{--pprAGraph :: (Outputable m, LastNode l, Outputable l) => AGraph n e x -> UniqSM SDoc-pprAGraph g = graphOfAGraph g >>= return . ppr--}--{--Note [Branch follows branch]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Why do we say it's ok for a Branch to follow a Branch?-Because the standard constructor mkLabel-- has fall-through-semantics. So if you do a mkLabel, you finish the current block,-giving it a label, and start a new one that branches to that label.-Emitting a Branch at this point is fine: -       goto L1; L2: ...stuff... --}+--------------------------------------------------------------+--               Boring instance declarations+--------------------------------------------------------------  -instance Labels Label where-  withFreshLabels f = A $ freshLabel >>= (graphOfAGraph . f)--instance (Labels l1, Labels l2) => Labels (l1, l2) where-  withFreshLabels f = withFreshLabels $ \l1 ->-                      withFreshLabels $ \l2 ->-                      f (l1, l2)+instance (Uniques u1, Uniques u2) => Uniques (u1, u2) where+  withFresh f = withFresh $ \u1 ->+                withFresh $ \u2 ->+                f (u1, u2) -instance (Labels l1, Labels l2, Labels l3) => Labels (l1, l2, l3) where-  withFreshLabels f = withFreshLabels $ \l1 ->-                      withFreshLabels $ \l2 ->-                      withFreshLabels $ \l3 ->-                      f (l1, l2, l3)+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 (Labels l1, Labels l2, Labels l3, Labels l4) => Labels (l1, l2, l3, l4) where-  withFreshLabels f = withFreshLabels $ \l1 ->-                      withFreshLabels $ \l2 ->-                      withFreshLabels $ \l3 ->-                      withFreshLabels $ \l4 ->-                      f (l1, l2, l3, l4)+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 -mkExit   block = A $ return $ GMany NothingO      BodyEmpty (JustO block)-mkEntry  block = A $ return $ GMany (JustO block) BodyEmpty NothingO+{-# 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 -mkFirst  = mkExit  . BUnit-mkLast   = mkEntry . BUnit-mkMiddle = A . return  . GUnit . BUnit+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

@@ -1,11 +1,13 @@ {-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-}  module Compiler.Hoopl.Show -  ( showGraph+  ( showGraph, showFactBase   ) where +import Compiler.Hoopl.Collections import Compiler.Hoopl.Graph+import Compiler.Hoopl.Label  -------------------------------------------------------------------------------- -- Prettyprinting@@ -14,18 +16,26 @@ type Showing n = forall e x . n e x -> String   -showGraph :: forall n e x . (Edges n) => Showing n -> Graph n e x -> String+showGraph :: forall n e x . (NonLocal n) => Showing n -> Graph n e x -> String showGraph node = g-  where g :: (Edges n) => Graph n e x -> String+  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 (map snd $ bodyList blocks)+        body blocks = concatMap b (mapElems blocks)         b :: forall e x . Block n e x -> String-        b (BUnit n)    = node n ++ "\n"-        b (BCat b1 b2) = b b1 ++ b b2+        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,128 @@+{-# 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.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)++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..]

@@ -2,8 +2,11 @@  module Compiler.Hoopl.Util   ( gUnitOO, gUnitOC, gUnitCO, gUnitCC+  , catGraphNodeOC, catGraphNodeOO+  , catNodeCOGraph, catNodeOOGraph   , graphMapBlocks-  , zblockGraph+  , blockMapNodes, blockMapNodes3+  , blockGraph   , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except   , preorder_dfs, preorder_dfs_from_except   , labelsDefined, labelsUsed, externalEntryLabels@@ -13,61 +16,110 @@  import Control.Monad +import Compiler.Hoopl.Collections import Compiler.Hoopl.Graph import Compiler.Hoopl.Label-import Compiler.Hoopl.Zipper ++----------------------------------------------------------------+ 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 :: block n C C -> Graph' block n C C+gUnitCC :: NonLocal (block n) => block n C C -> Graph' block n C C gUnitOO b = GUnit b-gUnitOC b = GMany (JustO b) BodyEmpty   NothingO-gUnitCO b = GMany NothingO  BodyEmpty   (JustO b)-gUnitCC b = GMany NothingO  (BodyUnit b) NothingO+gUnitOC b = GMany (JustO b) emptyBody  NothingO+gUnitCO b = GMany NothingO  emptyBody (JustO b)+gUnitCC b = GMany NothingO  (addBlock b emptyBody) NothingO -zblockGraph :: ZBlock n e x -> ZGraph n e x-zblockGraph b@(ZFirst  {}) = gUnitCO b-zblockGraph b@(ZMiddle {}) = gUnitOO b-zblockGraph b@(ZLast   {}) = gUnitOC b-zblockGraph b@(ZCat {})    = gUnitOO b-zblockGraph b@(ZHead {})   = gUnitCO b-zblockGraph b@(ZTail {})   = gUnitOC b-zblockGraph b@(ZClosed {}) = gUnitCC b +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)-bodyMapBlocks  :: forall block n block' n' .-                  (block n C C -> block' n' C C)-               -> (Body' block n -> Body' block' n')  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) (bodyMapBlocks f b) (fmap f x)+        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x) -bodyMapBlocks f = map-  where map BodyEmpty = BodyEmpty-        map (BodyUnit b) = BodyUnit (f b)-        map (BodyCat b1 b2) = BodyCat (map b1) (map b2)+-- | 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 Edges n => LabelsPtr (n e C) where+instance NonLocal n => LabelsPtr (n e C) where   targetLabels n = successors n  instance LabelsPtr Label where   targetLabels l = [l]  instance LabelsPtr LabelSet where-  targetLabels = labelSetElems+  targetLabels = setElems  instance LabelsPtr l => LabelsPtr [l] where   targetLabels = concatMap targetLabels@@ -88,8 +140,8 @@ -- one doesn't want to try and maintain both forward and backward -- versions.) -postorder_dfs :: Edges (block n) => Graph' block n O x -> [block n C C]-preorder_dfs  :: Edges (block n) => Graph' block n O x -> [block n C C]+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@@ -114,42 +166,41 @@ -- Better to get [A,B,C,D]  -graphDfs :: (Edges (block n))+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 blockenv entry emptyLabelSet-  where blockenv = bodyMap body+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 . (Edges block, LabelsPtr e)+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 elemLabelSet id visited then+        if setMember id visited then             cont acc visited         else             let cont' acc visited = cont (block:acc) visited in-            vchildren (get_children block) cont' acc (extendLabelSet visited id)+            vchildren (get_children block) cont' acc (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 blocks id of+   add_id id rst = case lookupFact id blocks of                       Just b -> b : rst                       Nothing -> rst  postorder_dfs_from-    :: (Edges block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]-postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyLabelSet+    :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]+postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty   ----------------------------------------------------------------@@ -160,10 +211,10 @@ instance Monad VM where   return a = VM $ \visited -> (a, visited)   m >>= k  = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v'-marked l = VM $ \v -> (elemLabelSet l v, v)-mark   l = VM $ \v -> ((), extendLabelSet v l)+marked l = VM $ \v -> (setMember l v, v)+mark   l = VM $ \v -> ((), setInsert l v) -preorder_dfs_from_except :: forall block e . (Edges block, LabelsPtr e)+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) []@@ -176,7 +227,7 @@                               bs <- children $ get_children b                               return $ b `cons` bs         get_children block = foldr add_id [] $ targetLabels block-        add_id id rst = case lookupFact blocks id of+        add_id id rst = case lookupFact id blocks of                           Just b -> b : rst                           Nothing -> rst @@ -186,31 +237,27 @@  ---------------------------------------------------------------- -labelsDefined :: forall block n e x . Edges (block n) => Graph' block n e x -> LabelSet-labelsDefined GNil      = emptyLabelSet-labelsDefined (GUnit{}) = emptyLabelSet-labelsDefined (GMany _ body x) = foldBodyBlocks addEntry body $ exitLabel x-  where addEntry block labels = extendLabelSet labels (entryLabel block)+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 = emptyLabelSet-        exitLabel (JustO b) = mkLabelSet [entryLabel b]+        exitLabel NothingO  = setEmpty+        exitLabel (JustO b) = setSingleton (entryLabel b) -labelsUsed :: forall block n e x. Edges (block n) => Graph' block n e x -> LabelSet-labelsUsed GNil      = emptyLabelSet-labelsUsed (GUnit{}) = emptyLabelSet-labelsUsed (GMany e body _) = foldBodyBlocks addTargets body $ entryTargets e-  where addTargets block labels = foldl extendLabelSet labels (successors block)+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 = emptyLabelSet-        entryTargets (JustO b) = addTargets b emptyLabelSet--foldBodyBlocks :: (block n C C -> a -> a) -> Body' block n -> a -> a-foldBodyBlocks _ BodyEmpty      = id-foldBodyBlocks f (BodyUnit b)   = f b-foldBodyBlocks f (BodyCat b b') = foldBodyBlocks f b . foldBodyBlocks f b'+        entryTargets NothingO = setEmpty+        entryTargets (JustO b) = addTargets b setEmpty -externalEntryLabels :: Edges (block n) => Body' block n -> LabelSet-externalEntryLabels body = defined `minusLabelSet` used+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,467 @@+{-# 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+  , 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 Data.Maybe++import Compiler.Hoopl.Collections+import Compiler.Hoopl.Dataflow+import Compiler.Hoopl.Fuel+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. (FuelMonad 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. (FuelMonad 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. (FuelMonad 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. (FuelMonad 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 => (n O C -> f -> f) -> (n O C -> f -> FactBase f)+distributeXfer xfer n f = mkFactBase [ (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 = mkFactBase [ (l, f) | l <- successors n ]++-- | 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 = mkFactBase [ (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]++-- | A fold function that relies on the EitherCO type function.+--   Note that the type parameter e is available to the functions+--   that are applied to the middle and last nodes.+tfFoldBlock :: forall n bc bo c e x .+               ( n C O -> bc+               , n O O -> EitherCO e bc bo -> EitherCO e bc bo+               , n O C -> EitherCO e bc bo -> c)+            -> (Block n e x -> bo -> EitherCO x c (EitherCO e bc bo))+tfFoldBlock (f, m, l) bl bo = block bl+  where block :: forall x . Block n e x -> EitherCO x c (EitherCO 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 -> EitherCO e bc bo -> EitherCO x c (EitherCO 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. ( EitherCO e (NodeList' C O n) (NodeList' O O n) ~ NodeList' e O n+                , EitherCO x (NodeList' e C n) (NodeList' e O n) ~ NodeList' e x n) =>+    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 -> EitherCO e a b -> EitherCO x c b)+fbnf3 (ff, fm, fl) block = unFF3 $ scottFoldBlock (ScottBlock f m l cat) block+    where f n = FF3 $ ff n+          m n = FF3 $ fm n+          l n = FF3 $ fl n+          FF3 f `cat` FF3 f' = FF3 $ f' . f++newtype FF3 a b c e x = FF3 { unFF3 :: EitherCO e a b -> EitherCO x c b }++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 -> EitherCO e a b -> EitherCO x c b)+foldBlockNodesF  :: forall n a .+                    (forall e x . n e x       -> a -> a)+                 -> (forall e x . Block n e x -> EitherCO e a a -> EitherCO x a a)+foldBlockNodesB3 :: forall n a b c .+                   ( n C O       -> b -> c+                   , n O O       -> b -> b+                   , n O C       -> a -> b)+                 -> (forall e x . Block n e x -> EitherCO x a b -> EitherCO e c b)+foldBlockNodesB  :: forall n a .+                    (forall e x . n e x       -> a -> a)+                 -> (forall e x . Block n e x -> EitherCO x a a -> EitherCO e a a)+-- | 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 -> EitherCO e a b -> EitherCO 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 -> EitherCO x a b -> EitherCO 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 EitherCO 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,568 +0,0 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- bug in GHC--{- Notes about the genesis of Hoopl7-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Hoopl7 has the following major chages--a) GMany has symmetric entry and exit-b) GMany closed-entry does not record a BlockId-c) GMany open-exit does not record a BlockId-d) The body of a GMany is called Body-e) A Body is just a list of blocks, not a map. I've argued-   elsewhere that this is consistent with (c)--A consequence is that Graph is no longer an instance of Edges,-but nevertheless I managed to keep the ARF and ARB signatures-nice and uniform.--This was made possible by--* FwdTransfer looks like this:-    type FwdTransfer n f-      = forall e x. n e x -> Fact e f -> Fact x f -    type family   Fact x f :: *-    type instance Fact C f = FactBase f-    type instance Fact O f = f--  Note that the incoming fact is a Fact (not just 'f' as in Hoopl5,6).-  It's up to the *transfer function* to look up the appropriate fact-  in the FactBase for a closed-entry node.  Example:-	constProp (Label l) fb = lookupFact fb l-  That is how Hoopl can avoid having to know the block-id for the-  first node: it defers to the client.--  [Side note: that means the client must know about -  bottom, in case the looupFact returns Nothing]--* Note also that FwdTransfer *returns* a Fact too;-  that is, the types in both directions are symmetrical.-  Previously we returned a [(BlockId,f)] but I could not see-  how to make everything line up if we do this.--  Indeed, the main shortcoming of Hoopl7 is that we are more-  or less forced into this uniform representation of the facts-  flowing into or out of a closed node/block/graph, whereas-  previously we had more flexibility.--  In exchange the code is neater, with fewer distinct types.-  And morally a FactBase is equivalent to [(BlockId,f)] and-  nearly equivalent to (BlockId -> f).--* I've realised that forwardBlockList and backwardBlockList-  both need (Edges n), and that goes everywhere.--* I renamed BlockId to Label--}--module Compiler.Hoopl.ZipDataflow -  ( FwdPass(..),  FwdTransfer, FwdRewrite, FwdRes(..)-  , BwdPass(..), BwdTransfer, BwdRewrite, BwdRes(..)-  , analyzeAndRewriteFwd,  analyzeAndRewriteBwd-  , analyzeAndRewriteFwd', analyzeAndRewriteBwd'-  )-where--import Compiler.Hoopl.Dataflow -           ( DataflowLattice(..), OldFact(..), NewFact(..)-           , ChangeFlag(..)-           , Fact-           )-import Compiler.Hoopl.Fuel-import Compiler.Hoopl.Graph-import qualified Compiler.Hoopl.GraphUtil as U-import Compiler.Hoopl.Label-import Compiler.Hoopl.Util-import Compiler.Hoopl.Zipper--type AGraph n e x = FuelMonad (ZGraph n e x)-graphOfAGraph :: AGraph n e x -> FuelMonad (ZGraph n e x)-graphOfAGraph = id----------------------------------------------------------------------------------		Analyze and rewrite forward: the interface--------------------------------------------------------------------------------data FwdPass n f-  = FwdPass { fp_lattice  :: DataflowLattice f-            , fp_transfer :: FwdTransfer n f-            , fp_rewrite  :: FwdRewrite n f }--type FwdTransfer n f -  = forall e x. n e x -> Fact e f -> Fact x f --type FwdRewrite n f -  = forall e x. n e x -> Fact e f -> Maybe (FwdRes n f e x)-data FwdRes n f e x = FwdRes (AGraph n e x) (FwdRewrite n f)-  -- result of a rewrite is a new graph and a (possibly) new rewrite function--analyzeAndRewriteFwd-   :: forall n f. Edges n-   => FwdPass n f-   -> ZBody n -> FactBase f-   -> FuelMonad (ZBody n, FactBase f)--analyzeAndRewriteFwd pass body facts-  = do { (rg, _) <- arfBody pass body facts-       ; return (normaliseBody rg) }---- | if the graph being analyzed is open at the entry, there must---   be no other entry point, or all goes horribly wrong...-analyzeAndRewriteFwd'-   :: forall n f e x. Edges n-   => FwdPass n f-   -> ZGraph n e x -> Fact e f-   -> FuelMonad (ZGraph n e x, FactBase f, MaybeO x f)-analyzeAndRewriteFwd' pass g f =-  do (rg, fout) <- arfGraph pass g f-     let (g', fb) = normalizeGraph g rg-     return (g', fb, distinguishedExitFact g' fout)--distinguishedExitFact :: forall n e x f . ZGraph n e x -> Fact x f -> MaybeO x f-distinguishedExitFact g f = maybe g-    where maybe :: ZGraph 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--normalizeGraph :: Edges n => ZGraph n e x -> RG n f e x -> GraphWithFacts n f e x-normalizeGraph GNil = normOO-normalizeGraph (GUnit {}) = normOO-normalizeGraph (GMany NothingO  _ NothingO)  = normCC-normalizeGraph (GMany (JustO _) _ NothingO)  = normOC-normalizeGraph (GMany NothingO  _ (JustO _)) = normCO-normalizeGraph (GMany (JustO _) _ (JustO _)) = normOO----------------------------------------------------------------------       Forward Implementation--------------------------------------------------------------------type ARF' n f thing e x-  = FwdPass n f -> thing e x -> Fact e f -> FuelMonad (RG n f e x, Fact x f)--type ARF thing n = forall f e x . ARF' n f thing e x---arfNode :: Edges n-        => (n e x -> ZBlock n e x)-        -> ARF' n f n e x-arfNode bunit pass node f-  = do { mb_g <- withFuel (fp_rewrite pass node f)-       ; case mb_g of-           Nothing -> return (RGUnit f (bunit node),-                              fp_transfer pass node f)-      	   Just (FwdRes ag rw) -> do { g <- graphOfAGraph ag-                                     ; let pass' = pass { fp_rewrite = rw }-                                     ; arfGraph pass' g f } }---- type demonstration-_arfBlock :: Edges n => ARF' n f (ZBlock n) e x-_arfBlock = arfBlock-_arfGraph :: Edges n => ARF' n f (ZGraph n) e x-_arfGraph = arfGraph---arfMiddle :: Edges n => ARF' n f n O O-arfMiddle = arfNode ZMiddle---arfBlock :: Edges n => ARF (ZBlock n) n--- Lift from nodes to blocks-arfBlock pass (ZFirst  node)  = arfNode ZFirst  pass node-arfBlock pass (ZMiddle node)  = arfNode ZMiddle pass node-arfBlock pass (ZLast   node)  = arfNode ZLast   pass node-arfBlock pass (ZCat b1 b2)    = arfCat arfBlock  arfBlock  pass b1 b2-arfBlock pass (ZHead h n)     = arfCat arfBlock  arfMiddle pass h n-arfBlock pass (ZTail n t)     = arfCat arfMiddle arfBlock  pass n t-arfBlock pass (ZClosed h t)   = arfCat arfBlock  arfBlock  pass h t--arfCat :: Edges n => ARF' n f thing1 e O -> ARF' n f thing2 O x-       -> FwdPass n f -> thing1 e O -> thing2 O x-       -> Fact e f -> FuelMonad (RG n f e x, Fact x f)-arfCat arf1 arf2 pass thing1 thing2 f = do { (g1,f1) <- arf1 pass thing1 f-                                           ; (g2,f2) <- arf2 pass thing2 f1-                                           ; return (g1 `RGCatO` g2, f2) }-arfBody :: Edges n-                  -        => FwdPass n f -> ZBody n -> FactBase f-        -> FuelMonad (RG n f C C, FactBase f)-		-- Outgoing factbase is restricted to Labels *not* in-		-- in the Body; the facts for Labels *in*-                -- the Body are in the BodyWithFacts-arfBody pass blocks init_fbase-  = fixpoint True (fp_lattice pass) (arfBlock pass) init_fbase $-    forwardBlockList (factBaseLabels init_fbase) blocks--arfGraph :: Edges n => ARF (ZGraph n) n--- Lift from blocks to graphs-arfGraph _    GNil        f = return (RGNil, f)-arfGraph pass (GUnit blk) f = arfBlock pass blk f-arfGraph pass (GMany NothingO body NothingO) f-  = do { (body', fb) <- arfBody pass body f-       ; return (body', fb) }-arfGraph pass (GMany NothingO body (JustO exit)) f-  = do { (body', fb) <- arfBody  pass body f-       ; (exit', fx) <- arfBlock pass exit fb-       ; return (body' `RGCatC` exit', fx) }-arfGraph pass (GMany (JustO entry) body NothingO) f-  = do { (entry', fe) <- arfBlock pass entry f-       ; (body', fb)  <- arfBody  pass body fe-       ; return (entry' `RGCatC` body', fb) }-arfGraph pass (GMany (JustO entry) body (JustO exit)) f-  = do { (entry', fe) <- arfBlock pass entry f-       ; (body', fb)  <- arfBody  pass body fe-       ; (exit', fx)  <- arfBlock pass exit fb-       ; return (entry' `RGCatC` body' `RGCatC` exit', fx) }--forwardBlockList :: (Edges n, LabelsPtr entry)-                 => entry -> ZBody n -> [ZBlock 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 (bodyMap blks) entries----------------------------------------------------------------------------------		Backward analysis and rewriting: the interface--------------------------------------------------------------------------------data BwdPass n f-  = BwdPass { bp_lattice  :: DataflowLattice f-            , bp_transfer :: BwdTransfer n f-            , bp_rewrite  :: BwdRewrite n f }--type BwdTransfer n f -  = forall e x. n e x -> Fact x f -> Fact e f -type BwdRewrite n f -  = forall e x. n e x -> Fact x f -> Maybe (BwdRes n f e x)-data BwdRes n f e x = BwdRes (AGraph n e x) (BwdRewrite n f)----------------------------------------------------------------------------------		Backward implementation--------------------------------------------------------------------------------type ARB' n f thing e x-  = BwdPass n f -> thing e x -> Fact x f -> FuelMonad (RG n f e x, Fact e f)--type ARB thing n = forall f e x. ARB' n f thing e x --arbNode :: Edges n-        => (n e x -> ZBlock n e x)-        -> ARB' n f n e x--- Lifts (BwdTransfer,BwdRewrite) to ARB_Node; --- this time we do rewriting as well. --- The ARB_Graph parameters specifies what to do with the rewritten graph-arbNode bunit pass node f-  = do { mb_g <- withFuel (bp_rewrite pass node f)-       ; case mb_g of-           Nothing -> return (RGUnit entry_f (bunit node), entry_f)-                    where-                      entry_f = bp_transfer pass node f-      	   Just (BwdRes ag rw) -> do { g <- graphOfAGraph ag-                                     ; let pass' = pass { bp_rewrite = rw }-                                     ; arbGraph pass' g f} }--arbMiddle :: Edges n => ARB' n f n O O-arbMiddle = arbNode ZMiddle--arbBlock :: Edges n => ARB (ZBlock n) n--- Lift from nodes to blocks-arbBlock pass (ZFirst  node)  = arbNode ZFirst  pass node-arbBlock pass (ZMiddle node)  = arbNode ZMiddle pass node-arbBlock pass (ZLast   node)  = arbNode ZLast   pass node-arbBlock pass (ZCat b1 b2)    = arbCat arbBlock  arbBlock  pass b1 b2-arbBlock pass (ZHead h n)     = arbCat arbBlock  arbMiddle pass h n-arbBlock pass (ZTail n t)     = arbCat arbMiddle arbBlock  pass n t-arbBlock pass (ZClosed h t)   = arbCat arbBlock  arbBlock  pass h t--arbCat :: Edges n => ARB' n f thing1 e O -> ARB' n f thing2 O x-       -> BwdPass n f -> thing1 e O -> thing2 O x-       -> Fact x f -> FuelMonad (RG n f e x, Fact e f)-arbCat arb1 arb2 pass thing1 thing2 f = do { (g2,f2) <- arb2 pass thing2 f-                                           ; (g1,f1) <- arb1 pass thing1 f2-                                           ; return (g1 `RGCatO` g2, f1) }--arbBody :: Edges n-        => BwdPass n f -> ZBody n -> FactBase f-        -> FuelMonad (RG n f C C, FactBase f)-arbBody pass blocks init_fbase-  = fixpoint False (bp_lattice pass) (arbBlock pass) init_fbase $-    backwardBlockList blocks --arbGraph :: Edges n => ARB (ZGraph n) n-arbGraph _    GNil        f = return (RGNil, f)-arbGraph pass (GUnit blk) f = arbBlock pass blk f-arbGraph pass (GMany NothingO body NothingO) f-  = do { (body', fb) <- arbBody pass body f-       ; return (body', fb) }-arbGraph pass (GMany NothingO body (JustO exit)) f-  = do { (exit', fx) <- arbBlock pass exit f-       ; (body', fb) <- arbBody  pass body fx-       ; return (body' `RGCatC` exit', fb) }-arbGraph pass (GMany (JustO entry) body NothingO) f-  = do { (body', fb)  <- arbBody  pass body f-       ; (entry', fe) <- arbBlock pass entry fb-       ; return (entry' `RGCatC` body', fe) }-arbGraph pass (GMany (JustO entry) body (JustO exit)) f-  = do { (exit', fx)  <- arbBlock pass exit f-       ; (body', fb)  <- arbBody  pass body fx-       ; (entry', fe) <- arbBlock pass entry fb-       ; return (entry' `RGCatC` body' `RGCatC` exit', fe) }--backwardBlockList :: Edges n => ZBody n -> [ZBlock 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 body = reachable ++ missing-  where reachable = reverse $ forwardBlockList entries body-        entries = externalEntryLabels body-        all = bodyList body-        missingLabels =-            mkLabelSet (map fst all) `minusLabelSet`-            mkLabelSet (map entryLabel reachable)-        missing = map snd $ filter (flip elemLabelSet missingLabels . fst) all--{---The forward and backward dataflow analyses now use postorder depth-first-order for faster convergence.--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.)--Since in the general case, no information is available about entry-points, I have put in a horrible hack.  First, I assume that every-label defined but not used is an entry point.  Then, because an entry-point might also be a loop header, I add, in arbitrary order, all the-remaining "missing" blocks.  Needless to say, I am not pleased.  -I am not satisfied.  I am not Senator Morgan.--Wait! I believe that the Right Thing here is to require that anyone-wishing to analyze a graph closed at the entry provide a way of-determining the entry points, if any, of that graph.  This requirement-can apply equally to forward and backward analyses; I believe that-using the input FactBase to determine the entry points of a closed-graph is *also* a hack.--NR---}---analyzeAndRewriteBwd-   :: forall n f. Edges n-   => BwdPass n f -   -> ZBody n -> FactBase f -   -> FuelMonad (ZBody n, FactBase f)--analyzeAndRewriteBwd pass body facts-  = do { (rg, _) <- arbBody pass body facts-       ; return (normaliseBody rg) }---- | if the graph being analyzed is open at the exit, I don't---   quite understand the implications of possible other exits-analyzeAndRewriteBwd'-   :: forall n f e x. Edges n-   => BwdPass n f-   -> ZGraph n e x -> Fact x f-   -> FuelMonad (ZGraph n e x, FactBase f, MaybeO e f)-analyzeAndRewriteBwd' pass g f =-  do (rg, fout) <- arbGraph pass g f-     let (g', fb) = normalizeGraph g rg-     return (g', fb, distinguishedEntryFact g' fout)--distinguishedEntryFact :: forall n e x f . ZGraph n e x -> Fact e f -> MaybeO e f-distinguishedEntryFact g f = maybe g-    where maybe :: ZGraph 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--------------------------------------------------------------------------------data TxFactBase n f-  = TxFB { tfb_fbase :: FactBase f-         , tfb_rg  :: RG n f C C -- Transformed blocks-         , tfb_cha   :: ChangeFlag-         , tfb_lbls  :: LabelSet }- -- Note [TxFactBase change flag]- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- Set the tfb_cha flag iff - --   (a) the fact in tfb_fbase for or a block L changes- --   (b) L is in tfb_lbls.- -- The tfb_lbls are all Labels of the *original* - -- (not transformed) blocks--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 `elemLabelSet` lbls = (SomeChange, new_fbase)-  | otherwise               = (cha,        new_fbase)-  where-    (cha2, res_fact) -- Note [Unreachable blocks]-       = case lookupFact fbase lbl of-           Nothing -> (SomeChange, snd $ join $ fact_bot lat)  -- Note [Unreachable blocks]-           Just old_fact -> join old_fact-         where join old_fact = fact_extend lat lbl (OldFact old_fact) (NewFact new_fact)-    new_fbase = extendFactBase fbase lbl res_fact--fixpoint :: forall block n f. Edges (block n)-         => Bool	-- Going forwards?-         -> DataflowLattice f-         -> (block n C C -> FactBase f-              -> FuelMonad (RG n f C C, FactBase f))-         -> FactBase f -         -> [block n C C]-         -> FuelMonad (RG n f C C, FactBase f)-fixpoint is_fwd lat do_block init_fbase untagged_blocks-  = do { fuel <- getFuel  -       ; tx_fb <- loop fuel init_fbase-       ; return (tfb_rg tx_fb, -                 tfb_fbase tx_fb `delFromFactBase` map fst blocks) }-	     -- The successors of the ZGraph are the the Labels for which-	     -- we have facts, that are *not* in the blocks of the graph-  where-    blocks = map tag untagged_blocks-     where tag b = ((entryLabel b, b), if is_fwd then [entryLabel b] else successors b)--    tx_blocks :: [((Label, block n C C), [Label])]   -- I do not understand this type-              -> TxFactBase n f -> FuelMonad (TxFactBase n f)-    tx_blocks []              tx_fb = return tx_fb-    tx_blocks (((lbl,blk), deps):bs) tx_fb = tx_block lbl blk deps tx_fb >>= tx_blocks bs-     -- "deps" == Labels the block may _depend_ upon for facts--    tx_block :: Label -> block n C C -> [Label]-             -> TxFactBase n f -> FuelMonad (TxFactBase n f)-    tx_block lbl blk deps tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls-                                      , tfb_rg = blks, tfb_cha = cha })-      | is_fwd && not (lbl `elemFactBase` fbase)-      = return tx_fb {tfb_lbls = lbls `unionLabelSet` mkLabelSet deps}	-- Note [Unreachable blocks]-      | otherwise-      = do { (rg, out_facts) <- do_block blk fbase-           ; let (cha',fbase') -                   = foldr (updateFact lat lbls) (cha,fbase) -                           (factBaseList out_facts)-                 lbls' = lbls `unionLabelSet` mkLabelSet deps-           ; return (TxFB { tfb_lbls  = lbls'-                          , tfb_rg    = rg `RGCatC` blks-                          , tfb_fbase = fbase', tfb_cha = cha' }) }--    loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f)-    loop fuel fbase -      = do { let init_tx_fb = TxFB { tfb_fbase = fbase-                                   , tfb_cha   = NoChange-                                   , tfb_rg    = RGNil-                                   , tfb_lbls  = emptyLabelSet }-           ; tx_fb <- tx_blocks blocks init_tx_fb-           ; case tfb_cha tx_fb of-               NoChange   -> return tx_fb-               SomeChange -> do { setFuel fuel-                                ; loop fuel (tfb_fbase tx_fb) } }--{- 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_extend 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.--}----------------------------------------------------------------------------------	RG: an internal data type for graphs under construction---          TOTALLY internal to Hoopl---------------------------------------------------------------------------------- this type exists because we have not yet found a way to write arfNode--- to return a Graph; the invariants of ZGraph seem too strong--data RG' block n f e x where-  RGNil   :: RG' block n f a a-  RGUnit  :: Fact e f -> block n e x -> RG' block n f e x-  RGCatO  :: RG' block n f e O -> RG' block n f O x -> RG' block n f e x-  RGCatC  :: RG' block n f e C -> RG' block n f C x -> RG' block n f e x-type RG = RG' ZBlock--type BodyWithFacts  n f     = (ZBody n, FactBase f)-type GraphWithFacts n f e x = (ZGraph n e x, FactBase f)-  -- A ZGraph together with the facts for that graph-  -- The domains of the two maps should be identical--normaliseBody :: Edges n => RG n f C C -> BodyWithFacts n f-normaliseBody rg = (body, fact_base)-  where-    (GMany _ body _, fact_base) = normCC rg--normOO :: Edges n => RG n f O O -> GraphWithFacts n f O O-normOO RGNil          = (GNil, noFacts)-normOO (RGUnit _ b)   = (GUnit b, noFacts)-normOO (RGCatO g1 g2) = normOO g1 `gwfCat` normOO g2-normOO (RGCatC g1 g2) = normOC g1 `gwfCat` normCO g2--normOC :: Edges n => RG n f O C -> GraphWithFacts n f O C-normOC (RGUnit _ b)   = (GMany (JustO b) BodyEmpty NothingO, noFacts)-normOC (RGCatO g1 g2) = normOO g1 `gwfCat` normOC g2-normOC (RGCatC g1 g2) = normOC g1 `gwfCat` normCC g2--normCO :: Edges n => RG n f C O -> GraphWithFacts n f C O-normCO (RGUnit f b) = (GMany NothingO BodyEmpty (JustO b), unitFact l f)-                    where-                      l = entryLabel b-normCO (RGCatO g1 g2) = normCO g1 `gwfCat` normOO g2-normCO (RGCatC g1 g2) = normCC g1 `gwfCat` normCO g2--normCC :: Edges n => RG n f C C -> GraphWithFacts n f C C-normCC RGNil        = (GMany NothingO BodyEmpty NothingO, noFacts)-normCC (RGUnit f b) = (GMany NothingO (BodyUnit b) NothingO, unitFact l f)-                    where-                      l = entryLabel b-normCC (RGCatO g1 g2) = normCO g1 `gwfCat` normOC g2-normCC (RGCatC g1 g2) = normCC g1 `gwfCat` normCC g2--gwfCat :: Edges n => GraphWithFacts n f e a-                  -> GraphWithFacts n f a x -                  -> GraphWithFacts n f e x-gwfCat (g1, fb1) (g2, fb2) = (g1 `U.zSplice` g2, fb1 `unionFactBase` fb2)--{--bwfUnion :: BodyWithFacts n f -> BodyWithFacts n f -> BodyWithFacts n f-bwfUnion (bg1, fb1) (bg2, fb2) = (bg1 `BodyCat` bg2, fb1 `unionFactBase` fb2)--}

@@ -1,556 +0,0 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- bug in GHC--{- Notes about the genesis of Hoopl7-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Hoopl7 has the following major chages--a) GMany has symmetric entry and exit-b) GMany closed-entry does not record a BlockId-c) GMany open-exit does not record a BlockId-d) The body of a GMany is called Body-e) A Body is just a list of blocks, not a map. I've argued-   elsewhere that this is consistent with (c)--A consequence is that Graph is no longer an instance of Edges,-but nevertheless I managed to keep the ARF and ARB signatures-nice and uniform.--This was made possible by--* FwdTransfer looks like this:-    type FwdTransfer n f-      = forall e x. n e x -> Fact e f -> Fact x f -    type family   Fact x f :: *-    type instance Fact C f = FactBase f-    type instance Fact O f = f--  Note that the incoming fact is a Fact (not just 'f' as in Hoopl5,6).-  It's up to the *transfer function* to look up the appropriate fact-  in the FactBase for a closed-entry node.  Example:-	constProp (Label l) fb = lookupFact fb l-  That is how Hoopl can avoid having to know the block-id for the-  first node: it defers to the client.--  [Side note: that means the client must know about -  bottom, in case the looupFact returns Nothing]--* Note also that FwdTransfer *returns* a Fact too;-  that is, the types in both directions are symmetrical.-  Previously we returned a [(BlockId,f)] but I could not see-  how to make everything line up if we do this.--  Indeed, the main shortcoming of Hoopl7 is that we are more-  or less forced into this uniform representation of the facts-  flowing into or out of a closed node/block/graph, whereas-  previously we had more flexibility.--  In exchange the code is neater, with fewer distinct types.-  And morally a FactBase is equivalent to [(BlockId,f)] and-  nearly equivalent to (BlockId -> f).--* I've realised that forwardBlockList and backwardBlockList-  both need (Edges n), and that goes everywhere.--* I renamed BlockId to Label--}--module Compiler.Hoopl.ZipDataflowNoRG-  ( FwdPass(..),  FwdTransfer, FwdRewrite, FwdRes(..)-  , BwdPass(..), BwdTransfer, BwdRewrite, BwdRes(..)-  , analyzeAndRewriteFwd,  analyzeAndRewriteBwd-  , analyzeAndRewriteFwd', analyzeAndRewriteBwd'-  )-where--import Compiler.Hoopl.Dataflow -           ( DataflowLattice(..), OldFact(..), NewFact(..)-           , ChangeFlag(..)-           , Fact-           )-import Compiler.Hoopl.Fuel-import Compiler.Hoopl.Graph-import qualified Compiler.Hoopl.GraphUtil as U-import Compiler.Hoopl.Label-import Compiler.Hoopl.Util-import Compiler.Hoopl.Zipper--type AGraph n e x = FuelMonad (ZGraph n e x)-graphOfAGraph :: AGraph n e x -> FuelMonad (ZGraph n e x)-graphOfAGraph = id----------------------------------------------------------------------------------		Analyze and rewrite forward: the interface--------------------------------------------------------------------------------data FwdPass n f-  = FwdPass { fp_lattice  :: DataflowLattice f-            , fp_transfer :: FwdTransfer n f-            , fp_rewrite  :: FwdRewrite n f }--type FwdTransfer n f -  = forall e x. n e x -> Fact e f -> Fact x f --type FwdRewrite n f -  = forall e x. n e x -> Fact e f -> Maybe (FwdRes n f e x)-data FwdRes n f e x = FwdRes (AGraph n e x) (FwdRewrite n f)-  -- result of a rewrite is a new graph and a (possibly) new rewrite function--analyzeAndRewriteFwd-   :: forall n f. Edges n-   => FwdPass n f-   -> ZBody n -> FactBase f-   -> FuelMonad (ZBody n, FactBase f)--analyzeAndRewriteFwd pass body facts-  = do { (rg, _) <- arfBody pass body facts-       ; return (normaliseBody rg) }---- | if the graph being analyzed is open at the entry, there must---   be no other entry point, or all goes horribly wrong...-analyzeAndRewriteFwd'-   :: forall n f e x. Edges n-   => FwdPass n f-   -> ZGraph n e x -> Fact e f-   -> FuelMonad (ZGraph n e x, FactBase f, MaybeO x f)-analyzeAndRewriteFwd' pass g f =-  do (rg, fout) <- arfGraph pass g f-     let (g', fb) = normalizeGraph rg-     return (g', fb, distinguishedExitFact g' fout)--distinguishedExitFact :: forall n e x f . ZGraph n e x -> Fact x f -> MaybeO x f-distinguishedExitFact g f = maybe g-    where maybe :: ZGraph 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 ARF' n f thing e x-  = FwdPass n f -> thing e x -> Fact e f -> FuelMonad (RG f n e x, Fact x f)--type ARF thing n = forall f e x . ARF' n f thing e x---arfNode :: Edges n-        => (n e x -> ZBlock n e x)-        -> ARF' n f n e x-arfNode bunit pass node f-  = do { mb_g <- withFuel (fp_rewrite pass node f)-       ; case mb_g of-           Nothing -> return (rgunit f (bunit node),-                              fp_transfer pass node f)-      	   Just (FwdRes ag rw) -> do { g <- graphOfAGraph ag-                                     ; let pass' = pass { fp_rewrite = rw }-                                     ; arfGraph pass' g f } }---- type demonstration-_arfBlock :: Edges n => ARF' n f (ZBlock n) e x-_arfBlock = arfBlock-_arfGraph :: Edges n => ARF' n f (ZGraph n) e x-_arfGraph = arfGraph---arfMiddle :: Edges n => ARF' n f n O O-arfMiddle = arfNode ZMiddle---arfBlock :: Edges n => ARF (ZBlock n) n--- Lift from nodes to blocks-arfBlock pass (ZFirst  node)  = arfNode ZFirst  pass node-arfBlock pass (ZMiddle node)  = arfNode ZMiddle pass node-arfBlock pass (ZLast   node)  = arfNode ZLast   pass node-arfBlock pass (ZCat b1 b2)    = arfCat arfBlock  arfBlock  pass b1 b2-arfBlock pass (ZHead h n)     = arfCat arfBlock  arfMiddle pass h n-arfBlock pass (ZTail n t)     = arfCat arfMiddle arfBlock  pass n t-arfBlock pass (ZClosed h t)   = arfCat arfBlock  arfBlock  pass h t--arfCat :: Edges n => ARF' n f thing1 e O -> ARF' n f thing2 O x-       -> FwdPass n f -> thing1 e O -> thing2 O x-       -> Fact e f -> FuelMonad (RG f n e x, Fact x f)-arfCat arf1 arf2 pass thing1 thing2 f = do { (g1,f1) <- arf1 pass thing1 f-                                           ; (g2,f2) <- arf2 pass thing2 f1-                                           ; return (g1 `rgCat` g2, f2) }-arfBody :: Edges n-                  -        => FwdPass n f -> ZBody n -> FactBase f-        -> FuelMonad (RG f n C C, FactBase f)-		-- Outgoing factbase is restricted to Labels *not* in-		-- in the Body; the facts for Labels *in*-                -- the Body are in the BodyWithFacts-arfBody pass blocks init_fbase-  = fixpoint True (fp_lattice pass) (arfBlock pass) init_fbase $-    forwardBlockList (factBaseLabels init_fbase) blocks--arfGraph :: Edges n => ARF (ZGraph n) n--- Lift from blocks to graphs-arfGraph _    GNil        f = return (rgnil, f)-arfGraph pass (GUnit blk) f = arfBlock pass blk f-arfGraph pass (GMany NothingO body NothingO) f-  = do { (body', fb) <- arfBody pass body f-       ; return (body', fb) }-arfGraph pass (GMany NothingO body (JustO exit)) f-  = do { (body', fb) <- arfBody  pass body f-       ; (exit', fx) <- arfBlock pass exit fb-       ; return (body' `rgCat` exit', fx) }-arfGraph pass (GMany (JustO entry) body NothingO) f-  = do { (entry', fe) <- arfBlock pass entry f-       ; (body', fb)  <- arfBody  pass body fe-       ; return (entry' `rgCat` body', fb) }-arfGraph pass (GMany (JustO entry) body (JustO exit)) f-  = do { (entry', fe) <- arfBlock pass entry f-       ; (body', fb)  <- arfBody  pass body fe-       ; (exit', fx)  <- arfBlock pass exit fb-       ; return (entry' `rgCat` body' `rgCat` exit', fx) }--forwardBlockList :: (Edges n, LabelsPtr entry)-                 => entry -> ZBody n -> [ZBlock 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 (bodyMap blks) entries----------------------------------------------------------------------------------		Backward analysis and rewriting: the interface--------------------------------------------------------------------------------data BwdPass n f-  = BwdPass { bp_lattice  :: DataflowLattice f-            , bp_transfer :: BwdTransfer n f-            , bp_rewrite  :: BwdRewrite n f }--type BwdTransfer n f -  = forall e x. n e x -> Fact x f -> Fact e f -type BwdRewrite n f -  = forall e x. n e x -> Fact x f -> Maybe (BwdRes n f e x)-data BwdRes n f e x = BwdRes (AGraph n e x) (BwdRewrite n f)----------------------------------------------------------------------------------		Backward implementation--------------------------------------------------------------------------------type ARB' n f thing e x-  = BwdPass n f -> thing e x -> Fact x f -> FuelMonad (RG f n e x, Fact e f)--type ARB thing n = forall f e x. ARB' n f thing e x --arbNode :: Edges n-        => (n e x -> ZBlock n e x)-        -> ARB' n f n e x--- Lifts (BwdTransfer,BwdRewrite) to ARB_Node; --- this time we do rewriting as well. --- The ARB_Graph parameters specifies what to do with the rewritten graph-arbNode bunit pass node f-  = do { mb_g <- withFuel (bp_rewrite pass node f)-       ; case mb_g of-           Nothing -> return (rgunit entry_f (bunit node), entry_f)-                    where-                      entry_f = bp_transfer pass node f-      	   Just (BwdRes ag rw) -> do { g <- graphOfAGraph ag-                                     ; let pass' = pass { bp_rewrite = rw }-                                     ; arbGraph pass' g f} }--arbMiddle :: Edges n => ARB' n f n O O-arbMiddle = arbNode ZMiddle--arbBlock :: Edges n => ARB (ZBlock n) n--- Lift from nodes to blocks-arbBlock pass (ZFirst  node)  = arbNode ZFirst  pass node-arbBlock pass (ZMiddle node)  = arbNode ZMiddle pass node-arbBlock pass (ZLast   node)  = arbNode ZLast   pass node-arbBlock pass (ZCat b1 b2)    = arbCat arbBlock  arbBlock  pass b1 b2-arbBlock pass (ZHead h n)     = arbCat arbBlock  arbMiddle pass h n-arbBlock pass (ZTail n t)     = arbCat arbMiddle arbBlock  pass n t-arbBlock pass (ZClosed h t)   = arbCat arbBlock  arbBlock  pass h t--arbCat :: Edges n => ARB' n f thing1 e O -> ARB' n f thing2 O x-       -> BwdPass n f -> thing1 e O -> thing2 O x-       -> Fact x f -> FuelMonad (RG f n e x, Fact e f)-arbCat arb1 arb2 pass thing1 thing2 f = do { (g2,f2) <- arb2 pass thing2 f-                                           ; (g1,f1) <- arb1 pass thing1 f2-                                           ; return (g1 `rgCat` g2, f1) }--arbBody :: Edges n-        => BwdPass n f -> ZBody n -> FactBase f-        -> FuelMonad (RG f n C C, FactBase f)-arbBody pass blocks init_fbase-  = fixpoint False (bp_lattice pass) (arbBlock pass) init_fbase $-    backwardBlockList blocks --arbGraph :: Edges n => ARB (ZGraph n) n-arbGraph _    GNil        f = return (rgnil, f)-arbGraph pass (GUnit blk) f = arbBlock pass blk f-arbGraph pass (GMany NothingO body NothingO) f-  = do { (body', fb) <- arbBody pass body f-       ; return (body', fb) }-arbGraph pass (GMany NothingO body (JustO exit)) f-  = do { (exit', fx) <- arbBlock pass exit f-       ; (body', fb) <- arbBody  pass body fx-       ; return (body' `rgCat` exit', fb) }-arbGraph pass (GMany (JustO entry) body NothingO) f-  = do { (body', fb)  <- arbBody  pass body f-       ; (entry', fe) <- arbBlock pass entry fb-       ; return (entry' `rgCat` body', fe) }-arbGraph pass (GMany (JustO entry) body (JustO exit)) f-  = do { (exit', fx)  <- arbBlock pass exit f-       ; (body', fb)  <- arbBody  pass body fx-       ; (entry', fe) <- arbBlock pass entry fb-       ; return (entry' `rgCat` body' `rgCat` exit', fe) }--backwardBlockList :: Edges n => ZBody n -> [ZBlock 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 body = reachable ++ missing-  where reachable = reverse $ forwardBlockList entries body-        entries = externalEntryLabels body-        all = bodyList body-        missingLabels =-            mkLabelSet (map fst all) `minusLabelSet`-            mkLabelSet (map entryLabel reachable)-        missing = map snd $ filter (flip elemLabelSet missingLabels . fst) all--{---The forward and backward dataflow analyses now use postorder depth-first-order for faster convergence.--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.)--Since in the general case, no information is available about entry-points, I have put in a horrible hack.  First, I assume that every-label defined but not used is an entry point.  Then, because an entry-point might also be a loop header, I add, in arbitrary order, all the-remaining "missing" blocks.  Needless to say, I am not pleased.  -I am not satisfied.  I am not Senator Morgan.--Wait! I believe that the Right Thing here is to require that anyone-wishing to analyze a graph closed at the entry provide a way of-determining the entry points, if any, of that graph.  This requirement-can apply equally to forward and backward analyses; I believe that-using the input FactBase to determine the entry points of a closed-graph is *also* a hack.--NR---}---analyzeAndRewriteBwd-   :: forall n f. Edges n-   => BwdPass n f -   -> ZBody n -> FactBase f -   -> FuelMonad (ZBody n, FactBase f)--analyzeAndRewriteBwd pass body facts-  = do { (rg, _) <- arbBody pass body facts-       ; return (normaliseBody rg) }---- | if the graph being analyzed is open at the exit, I don't---   quite understand the implications of possible other exits-analyzeAndRewriteBwd'-   :: forall n f e x. Edges n-   => BwdPass n f-   -> ZGraph n e x -> Fact x f-   -> FuelMonad (ZGraph n e x, FactBase f, MaybeO e f)-analyzeAndRewriteBwd' pass g f =-  do (rg, fout) <- arbGraph pass g f-     let (g', fb) = normalizeGraph rg-     return (g', fb, distinguishedEntryFact g' fout)--distinguishedEntryFact :: forall n e x f . ZGraph n e x -> Fact e f -> MaybeO e f-distinguishedEntryFact g f = maybe g-    where maybe :: ZGraph 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--------------------------------------------------------------------------------data TxFactBase n f-  = TxFB { tfb_fbase :: FactBase f-         , tfb_rg  :: RG f n C C -- Transformed blocks-         , tfb_cha   :: ChangeFlag-         , tfb_lbls  :: LabelSet }- -- Note [TxFactBase change flag]- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- Set the tfb_cha flag iff - --   (a) the fact in tfb_fbase for or a block L changes- --   (b) L is in tfb_lbls.- -- The tfb_lbls are all Labels of the *original* - -- (not transformed) blocks--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 `elemLabelSet` lbls = (SomeChange, new_fbase)-  | otherwise               = (cha,        new_fbase)-  where-    (cha2, res_fact) -- Note [Unreachable blocks]-       = case lookupFact fbase lbl of-           Nothing -> (SomeChange, snd $ join $ fact_bot lat)  -- Note [Unreachable blocks]-           Just old_fact -> join old_fact-         where join old_fact = fact_extend lat lbl (OldFact old_fact) (NewFact new_fact)-    new_fbase = extendFactBase fbase lbl res_fact--fixpoint :: forall block n f. Edges (block n)-         => Bool	-- Going forwards?-         -> DataflowLattice f-         -> (block n C C -> FactBase f-              -> FuelMonad (RG f n C C, FactBase f))-         -> FactBase f -         -> [block n C C]-         -> FuelMonad (RG f n C C, FactBase f)-fixpoint is_fwd lat do_block init_fbase untagged_blocks-  = do { fuel <- getFuel  -       ; tx_fb <- loop fuel init_fbase-       ; return (tfb_rg tx_fb, -                 tfb_fbase tx_fb `delFromFactBase` map fst blocks) }-	     -- The successors of the ZGraph are the the Labels for which-	     -- we have facts, that are *not* in the blocks of the graph-  where-    blocks = map tag untagged_blocks-     where tag b = ((entryLabel b, b), if is_fwd then [entryLabel b] else successors b)--    tx_blocks :: [((Label, block n C C), [Label])]   -- I do not understand this type-              -> TxFactBase n f -> FuelMonad (TxFactBase n f)-    tx_blocks []              tx_fb = return tx_fb-    tx_blocks (((lbl,blk), deps):bs) tx_fb = tx_block lbl blk deps tx_fb >>= tx_blocks bs-     -- "deps" == Labels the block may _depend_ upon for facts--    tx_block :: Label -> block n C C -> [Label]-             -> TxFactBase n f -> FuelMonad (TxFactBase n f)-    tx_block lbl blk deps tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls-                                      , tfb_rg = blks, tfb_cha = cha })-      | is_fwd && not (lbl `elemFactBase` fbase)-      = return tx_fb {tfb_lbls = lbls `unionLabelSet` mkLabelSet deps}	-- Note [Unreachable blocks]-      | otherwise-      = do { (rg, out_facts) <- do_block blk fbase-           ; let (cha',fbase') -                   = foldr (updateFact lat lbls) (cha,fbase) -                           (factBaseList out_facts)-                 lbls' = lbls `unionLabelSet` mkLabelSet deps-           ; return (TxFB { tfb_lbls  = lbls'-                          , tfb_rg    = rg `rgCat` blks-                          , tfb_fbase = fbase', tfb_cha = cha' }) }--    loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f)-    loop fuel fbase -      = do { let init_tx_fb = TxFB { tfb_fbase = fbase-                                   , tfb_cha   = NoChange-                                   , tfb_rg    = rgnilC-                                   , tfb_lbls  = emptyLabelSet }-           ; tx_fb <- tx_blocks blocks init_tx_fb-           ; case tfb_cha tx_fb of-               NoChange   -> return tx_fb-               SomeChange -> do { setFuel fuel-                                ; loop fuel (tfb_fbase tx_fb) } }--{- 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_extend 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.--}----------------------------------------------------------------------------------	RG: an internal data type for graphs under construction---          TOTALLY internal to Hoopl; each block carries its fact--------------------------------------------------------------------------------type RG      f n e x = Graph' (FZBlock f) n e x-data FZBlock f n e x = FZBlock (Fact e f) (ZBlock n e x)----- constructors--rgnil  :: RG f n O O-rgnilC :: RG f n C C-rgunit :: Fact e f -> ZBlock n e x -> RG f n e x-rgCat  :: RG f n e a -> RG f n a x -> RG f n e x------ observers--type BodyWithFacts  n f     = (ZBody n, FactBase f)-type GraphWithFacts n f e x = (ZGraph n e x, FactBase f)-  -- A ZGraph together with the facts for that graph-  -- The domains of the two maps should be identical--normalizeGraph :: forall n f e x .-                  Edges n => RG f n e x -> GraphWithFacts n f e x-normaliseBody  :: Edges n => RG f n C C -> BodyWithFacts n f--normalizeGraph g = (graphMapBlocks dropFact g, facts g)-    where dropFact (FZBlock _ b) = b-          facts :: RG f n e x -> FactBase f-          facts GNil = noFacts-          facts (GUnit _) = noFacts-          facts (GMany _ body exit) = bodyFacts body `unionFactBase` exitFacts exit-          exitFacts :: MaybeO x (FZBlock f n C O) -> FactBase f-          exitFacts NothingO = noFacts-          exitFacts (JustO (FZBlock f b)) = unitFact (entryLabel b) f-          bodyFacts :: Body' (FZBlock f) n -> FactBase f-          bodyFacts (BodyUnit (FZBlock f b)) = unitFact (entryLabel b) f-          bodyFacts (b1 `BodyCat` b2) = bodyFacts b1 `unionFactBase` bodyFacts b2--normaliseBody rg = (body, fact_base)-  where (GMany _ body _, fact_base) = normalizeGraph rg----- implementation of the constructors (boring)--rgnil  = GNil-rgnilC = GMany NothingO BodyEmpty NothingO--rgunit f b@(ZFirst  {}) = gUnitCO (FZBlock f b)-rgunit f b@(ZMiddle {}) = gUnitOO (FZBlock f b)-rgunit f b@(ZLast   {}) = gUnitOC (FZBlock f b)-rgunit f b@(ZCat {})    = gUnitOO (FZBlock f b)-rgunit f b@(ZHead {})   = gUnitCO (FZBlock f b)-rgunit f b@(ZTail {})   = gUnitOC (FZBlock f b)-rgunit f b@(ZClosed {}) = gUnitCC (FZBlock f b)--rgCat = U.splice fzCat-  where fzCat (FZBlock f b1) (FZBlock _ b2) = FZBlock f (b1 `U.zCat` b2)

@@ -1,90 +0,0 @@-{-# LANGUAGE GADTs #-}--module Compiler.Hoopl.Zipper-  ( ZBlock(..), ZGraph, ZBody-  , frontBiasBlock, backBiasBlock-  )-where--import Compiler.Hoopl.Graph--data ZBlock n e x where-  -- nodes-  ZFirst  :: n C O                 -> ZBlock n C O-  ZMiddle :: n O O                 -> ZBlock n O O-  ZLast   :: n O C                 -> ZBlock n O C--  -- concatenation operations-  ZCat    :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O -- non-list-like-  ZHead   :: ZBlock n C O -> n O O        -> ZBlock n C O-  ZTail   :: n O O        -> ZBlock n O C -> ZBlock n O C  --  ZClosed :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C -- the zipper--type ZGraph = Graph' ZBlock-type ZBody  = Body'  ZBlock--instance Edges n => Edges (ZBlock n) where-  entryLabel (ZFirst n)    = entryLabel n-  entryLabel (ZHead h _)   = entryLabel h-  entryLabel (ZClosed h _) = entryLabel h-  successors (ZLast n)     = successors n-  successors (ZTail _ t)   = successors t-  successors (ZClosed _ t) = successors t----------------------------------------------------------------------- | 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 :: ZBlock n e x -> ZBlock n e x-frontBiasBlock b@(ZFirst  {}) = b-frontBiasBlock b@(ZMiddle {}) = b-frontBiasBlock b@(ZLast   {}) = b-frontBiasBlock b@(ZCat {}) = rotate b-  where -- rotate and append ensure every left child of ZCat is ZMiddle-        -- provided 2nd argument to append already has this property-    rotate :: ZBlock n O O -> ZBlock n O O-    append :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O-    rotate (ZCat h t)     = append h (rotate t)-    rotate b@(ZMiddle {}) = b-    append b@(ZMiddle {}) t = b `ZCat` t-    append (ZCat b1 b2) b3 = b1 `append` (b2 `append` b3)-frontBiasBlock b@(ZHead {}) = b -- back-biased by nature; cannot fix-frontBiasBlock b@(ZTail {}) = b -- statically front-biased-frontBiasBlock (ZClosed h t) = shiftRight h t-    where shiftRight :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C-          shiftRight (ZHead b1 b2) b3 = shiftRight b1 (ZTail b2 b3)-          shiftRight b1@(ZFirst {}) b2 = ZClosed 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 :: ZBlock n e x -> ZBlock n e x-backBiasBlock b@(ZFirst  {}) = b-backBiasBlock b@(ZMiddle {}) = b-backBiasBlock b@(ZLast   {}) = b-backBiasBlock b@(ZCat {}) = rotate b-  where -- rotate and append ensure every right child of ZCat is ZMiddle-        -- provided 1st argument to append already has this property-    rotate :: ZBlock n O O -> ZBlock n O O-    append :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O-    rotate (ZCat h t)     = append (rotate h) t-    rotate b@(ZMiddle {}) = b-    append h b@(ZMiddle {}) = h `ZCat` b-    append b1 (ZCat b2 b3) = (b1 `append` b2) `append` b3-backBiasBlock b@(ZHead {}) = b -- statically back-biased-backBiasBlock b@(ZTail {}) = b -- front-biased by nature; cannot fix-backBiasBlock (ZClosed h t) = shiftLeft h t-    where shiftLeft :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C-          shiftLeft b1 (ZTail b2 b3) = shiftLeft (ZHead b1 b2) b3-          shiftLeft b1 b2@(ZLast {}) = ZClosed b1 b2

@@ -0,0 +1,20 @@+ > in GHC we quite often we want to get the entry or the last node of a block.+ > Currently that can take up to linear time in the length of a block, right?+ > Are there any plans to improve it, perhaps by changing the representation+ > of a block?++Milan,++The current representation can be either 'front-biased' or+'back-biased' to make one of those operations constant time.+The previous representation was always front-biased and we never noted+any performance problems.++If, and only if, you find a situation where you have measured a+significant performance problem, I suggest that you wrap the existing+block in a new block type that caches the information you need.+The representation Graph' is polymorphic precisely to enable this sort+of trickery; you'll see a different application in the dataflow+module, where a fact is stored with every block.++

@@ -1,5 +1,5 @@ Name:                hoopl-Version:             3.7.12.1+Version:             3.8.3.0 Description:         Higher-order optimization library License:             BSD3 License-file:        LICENSE@@ -11,24 +11,30 @@ Stability:           alpha Synopsis:            A library to support dataflow analysis and optimization Category:            Compilers/Interpreters-Extra-source-files:  README, hoopl.pdf, CHANGES+Extra-source-files:  README, hoopl.pdf, CHANGES, FAQ  Library   Build-Depends:     base >= 3 && < 5, containers   Exposed-modules:   Compiler.Hoopl,-                       Compiler.Hoopl.Zipper,-                       Compiler.Hoopl.ZipDataflowNoRG+                     Compiler.Hoopl.Passes.Dominator,+                     Compiler.Hoopl.Passes.DList,+--                       Compiler.Hoopl.DataflowFold,+--                       Compiler.Hoopl.OldDataflow,+                       Compiler.Hoopl.GHC   Other-modules:     Compiler.Hoopl.GraphUtil,                      -- GraphUtil should *never* be seen by clients.                      -- The remaining modules are hidden *provisionally*+                       Compiler.Hoopl.Collections,                        Compiler.Hoopl.Combinators,                        Compiler.Hoopl.Dataflow,                        Compiler.Hoopl.Debug,                        Compiler.Hoopl.Graph,                         Compiler.Hoopl.MkGraph,-                       Compiler.Hoopl.Fuel, Compiler.Hoopl.Label,+                       Compiler.Hoopl.Fuel,+                       Compiler.Hoopl.Pointed,+                       Compiler.Hoopl.Unique, Compiler.Hoopl.Label,                        Compiler.Hoopl.Show, Compiler.Hoopl.Util-                       Compiler.Hoopl.ZipDataflow+                       Compiler.Hoopl.XUtil   ghc-options:       -Wall -fno-warn-name-shadowing  

binary file changed (258240 → 245436 bytes)