hoopl 3.8.7.4 → 3.9.0.0

raw patch · 20 files changed

+1031/−1099 lines, 20 filesnew-uploaderPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• FAQ +0/−20
• LICENSE +1/−1
• README +2/−0
• hoopl.cabal +17/−11
• src/Compiler/Hoopl.hs +4/−8
• src/Compiler/Hoopl/Block.hs +421/−0
• src/Compiler/Hoopl/Collections.hs +2/−0
• src/Compiler/Hoopl/Combinators.hs +2/−1
• src/Compiler/Hoopl/Dataflow.hs +146/−143
• src/Compiler/Hoopl/GHC.hs +0/−27
• src/Compiler/Hoopl/Graph.hs +372/−107
• src/Compiler/Hoopl/GraphUtil.hs +0/−127
• src/Compiler/Hoopl/Internals.hs +18/−0
• src/Compiler/Hoopl/Label.hs +2/−0
• src/Compiler/Hoopl/MkGraph.hs +4/−4
• src/Compiler/Hoopl/Pointed.hs +1/−1
• src/Compiler/Hoopl/Show.hs +8/−6
• src/Compiler/Hoopl/Unique.hs +24/−23
• src/Compiler/Hoopl/Util.hs +0/−271
• src/Compiler/Hoopl/XUtil.hs +7/−349

@@ -1,20 +0,0 @@- > 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,4 +1,4 @@-Copyright (c) 2010, João Dias, Simon Peyton Jones, and Norman Ramsey+Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones, and Norman Ramsey All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -24,3 +24,5 @@    cabal sdist   cabal upload dist/something.tar.gz++Developers, please see HOWTO-BRANCHES

@@ -1,14 +1,21 @@ Name:                hoopl-Version:             3.8.7.4+Version:             3.9.0.0 -- version 3.8.6.0 is the version that goes with the camera-ready Haskell'10 paper -- version 3.8.7.0 works with GHC 7 -- version 3.8.7.1 adds some unnamed functions without breaking compatibility -- version 3.8.7.2 adds Compiler.Hoopl.Fuel.liftFuel -- version 3.8.7.4 re-exports runWithFuel-Description:         Higher-order optimization library+-- version 3.9.0.0 adds the new API for working with blocks, and lots of internal refactoring+Description:+  Higher-order optimization library+  .+  Changes in 3.9.0.0+  .+  * Lots of API changes; mainly a new API for working with Blocks+ License:             BSD3 License-File:        LICENSE-Author:              Norman Ramsey, João Dias, and Simon Peyton Jones+Author:              Norman Ramsey, João Dias, Simon Marlow and Simon Peyton Jones Maintainer:          nr@cs.tufts.edu Homepage:            http://ghc.cs.tufts.edu/hoopl/ Build-Type:          Simple@@ -21,21 +28,21 @@   Hs-Source-Dirs:    src   Build-Depends:     base >= 3 && < 5, containers   Exposed-Modules:   Compiler.Hoopl,+                     Compiler.Hoopl.Internals,                      Compiler.Hoopl.Wrappers,                      Compiler.Hoopl.Passes.Dominator,-                     Compiler.Hoopl.Passes.DList,+                     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.Checkpoint,++  -- The remaining modules are hidden *provisionally*+  Other-modules:     Compiler.Hoopl.Checkpoint,                      Compiler.Hoopl.Collections,                      Compiler.Hoopl.Combinators,                      Compiler.Hoopl.Dataflow,                      Compiler.Hoopl.Debug,-                     Compiler.Hoopl.Graph, +                     Compiler.Hoopl.Block,+                     Compiler.Hoopl.Graph,                      Compiler.Hoopl.Label,                      Compiler.Hoopl.MkGraph,                      Compiler.Hoopl.Fuel,@@ -43,7 +50,6 @@                      Compiler.Hoopl.Shape,                      Compiler.Hoopl.Show,                       Compiler.Hoopl.Unique, -                     Compiler.Hoopl.Util,                      Compiler.Hoopl.XUtil    Ghc-Options:       -Wall -fno-warn-name-shadowing

@@ -4,6 +4,7 @@  module Compiler.Hoopl   ( module Compiler.Hoopl.Graph+  , module Compiler.Hoopl.Block   , module Compiler.Hoopl.MkGraph   , module Compiler.Hoopl.XUtil   , module Compiler.Hoopl.Collections@@ -14,7 +15,6 @@   , module Compiler.Hoopl.Combinators   , module Compiler.Hoopl.Fuel   , module Compiler.Hoopl.Unique-  , module Compiler.Hoopl.Util   , module Compiler.Hoopl.Debug   , module Compiler.Hoopl.Show   )@@ -26,16 +26,12 @@ import Compiler.Hoopl.Dataflow hiding ( wrapFR, wrapFR2, wrapBR, wrapBR2                                       ) import Compiler.Hoopl.Debug-import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel)-import Compiler.Hoopl.Graph hiding -   ( Body-   , BCat, BHead, BTail, BClosed -- OK to expose BFirst, BMiddle, BLast-   )-import Compiler.Hoopl.Graph (Body)+import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel, runWithFuel)+import Compiler.Hoopl.Block+import Compiler.Hoopl.Graph hiding (splice, gSplice) 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,421 @@+{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies, ScopedTypeVariables, RankNTypes #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Safe #-}+#endif++module Compiler.Hoopl.Block (+    -- * Shapes+    O, C+  , MaybeO(..), MaybeC(..)+  , IndexedCO+  , Shape(..)++    -- * Blocks+  , Block(..)++    -- ** Predicates on Blocks+  , isEmptyBlock++    -- ** Constructing blocks+  , emptyBlock, blockCons, blockSnoc+  , blockJoinHead, blockJoinTail, blockJoin, blockJoinAny+  , blockAppend++    -- ** Deconstructing blocks+  , firstNode, lastNode, endNodes+  , blockSplitHead, blockSplitTail, blockSplit, blockSplitAny++    -- ** Modifying blocks+  , replaceFirstNode, replaceLastNode++    -- ** Converting to and from lists+  , blockToList, blockFromList++    -- ** Maps and folds+  , mapBlock, mapBlock', mapBlock3'+  , foldBlockNodesF, foldBlockNodesF3+  , foldBlockNodesB, foldBlockNodesB3++    -- ** Biasing+  , frontBiasBlock, backBiasBlock++  ) where+++-- -----------------------------------------------------------------------------+-- Shapes: Open and Closed++-- | 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++-- | Either type indexed by closed/open using type families+type family IndexedCO ex a b :: *+type instance IndexedCO C a b = a+type instance IndexedCO O a b = b++-- | 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+++instance Functor (MaybeO ex) where+  fmap _ NothingO = NothingO+  fmap f (JustO a) = JustO (f a)++instance Functor (MaybeC ex) where+  fmap _ NothingC = NothingC+  fmap f (JustC a) = JustC (f a)+++-- | Dynamic shape value+data Shape ex where+  Closed :: Shape C+  Open   :: Shape O+++-- -----------------------------------------------------------------------------+-- The Block type++-- | 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+  BlockCO  :: n C O -> Block n O O          -> Block n C O+  BlockCC  :: n C O -> Block n O O -> n O C -> Block n C C+  BlockOC  ::          Block n O O -> n O C -> Block n O C++  BNil    :: Block n O O+  BMiddle :: n O O                      -> Block n O O+  BCat    :: Block n O O -> Block n O O -> Block n O O+  BSnoc   :: Block n O O -> n O O       -> Block n O O+  BCons   :: n O O       -> Block n O O -> Block n O O+++-- -----------------------------------------------------------------------------+-- Simple operations on Blocks++-- Predicates++isEmptyBlock :: Block n e x -> Bool+isEmptyBlock BNil       = True+isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r+isEmptyBlock _          = False+++-- Building++emptyBlock :: Block n O O+emptyBlock = BNil++blockCons :: n O O -> Block n O x -> Block n O x+blockCons n b = case b of+  BlockOC b l  -> BlockOC (n `BCons` b) l+  BNil{}    -> n `BCons` b+  BMiddle{} -> n `BCons` b+  BCat{}    -> n `BCons` b+  BSnoc{}   -> n `BCons` b+  BCons{}   -> n `BCons` b++blockSnoc :: Block n e O -> n O O -> Block n e O+blockSnoc b n = case b of+  BlockCO f b -> BlockCO f (b `BSnoc` n)+  BNil{}      -> b `BSnoc` n+  BMiddle{}   -> b `BSnoc` n+  BCat{}      -> b `BSnoc` n+  BSnoc{}     -> b `BSnoc` n+  BCons{}     -> b `BSnoc` n++blockJoinHead :: n C O -> Block n O x -> Block n C x+blockJoinHead f (BlockOC b l) = BlockCC f b l+blockJoinHead f b = BlockCO f BNil `cat` b++blockJoinTail :: Block n e O -> n O C -> Block n e C+blockJoinTail (BlockCO f b) t = BlockCC f b t+blockJoinTail b t = b `cat` BlockOC BNil t++blockJoin :: n C O -> Block n O O -> n O C -> Block n C C+blockJoin f b t = BlockCC f b t++blockAppend :: Block n e O -> Block n O x -> Block n e x+blockAppend = cat+++-- Taking apart++firstNode :: Block n C x -> n C O+firstNode (BlockCO n _)   = n+firstNode (BlockCC n _ _) = n++lastNode :: Block n x C -> n O C+lastNode (BlockOC   _ n) = n+lastNode (BlockCC _ _ n) = n++endNodes :: Block n C C -> (n C O, n O C)+endNodes (BlockCC f _ l) = (f,l)++blockSplitHead :: Block n C x -> (n C O, Block n O x)+blockSplitHead (BlockCO n b)   = (n, b)+blockSplitHead (BlockCC n b t) = (n, BlockOC b t)++blockSplitTail :: Block n e C -> (Block n e O, n O C)+blockSplitTail (BlockOC b n)   = (b, n)+blockSplitTail (BlockCC f b t) = (BlockCO f b, t)++-- | Split a closed block into its entry node, open middle block, and+-- exit node.+blockSplit :: Block n C C -> (n C O, Block n O O, n O C)+blockSplit (BlockCC f b t) = (f, b, t)++blockSplitAny :: Block n e x+              -> (MaybeC e (n C O), Block n O O, MaybeC x (n O C))+blockSplitAny block = case block of+  BlockCO f b   -> (JustC f,  b, NothingC)+  BlockCC f b l -> (JustC f,  b, JustC l)+  BlockOC   b l -> (NothingC, b, JustC l)+  b@BNil        -> (NothingC, b, NothingC)+  b@BMiddle{}   -> (NothingC, b, NothingC)+  b@BCat{}      -> (NothingC, b, NothingC)+  b@BCons{}     -> (NothingC, b, NothingC)+  b@BSnoc{}     -> (NothingC, b, NothingC)++blockToList :: Block n O O -> [n O O]+blockToList b = go b []+   where go :: Block n O O -> [n O O] -> [n O O]+         go BNil         r = r+         go (BMiddle n)  r = n : r+         go (BCat b1 b2) r = go b1 $! go b2 r+         go (BSnoc b1 n) r = go b1 (n:r)+         go (BCons n b1) r = n : go b1 r++blockFromList :: [n O O] -> Block n O O+blockFromList = foldr BCons BNil+++-- | 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.+--+blockJoinAny :: (MaybeC e (n C O), Block n O O, MaybeC x (n O C)) -> Block n e x+blockJoinAny (NothingC, m, NothingC)  = m+blockJoinAny (NothingC, m, JustC l)   = BlockOC   m l+blockJoinAny (JustC f, m, NothingC)   = BlockCO f m+blockJoinAny (JustC f, m, JustC l)    = BlockCC f m l+++-- Modifying++replaceFirstNode :: Block n C x -> n C O -> Block n C x+replaceFirstNode (BlockCO _ b)   f = BlockCO f b+replaceFirstNode (BlockCC _ b n) f = BlockCC f b n++replaceLastNode :: Block n x C -> n O C -> Block n x C+replaceLastNode (BlockOC   b _) n = BlockOC b n+replaceLastNode (BlockCC l b _) n = BlockCC l b n+++-- -----------------------------------------------------------------------------+-- General concatenation++cat :: Block n e O -> Block n O x -> Block n e x+cat x y = case x of+  BNil -> y++  BlockCO l b1 -> case y of+                   BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n+                   BNil         -> x+                   BMiddle _    -> BlockCO l $! (b1 `cat` y)+                   BCat{}       -> BlockCO l $! (b1 `cat` y)+                   BSnoc{}      -> BlockCO l $! (b1 `cat` y)+                   BCons{}      -> BlockCO l $! (b1 `cat` y)++  BMiddle n -> case y of+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2+                   BNil          -> x+                   BMiddle{}     -> BCons n y+                   BCat{}        -> BCons n y+                   BSnoc{}       -> BCons n y+                   BCons{}       -> BCons n y++  BCat{} -> case y of+                   BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2+                   BNil          -> x+                   BMiddle n     -> BSnoc x n+                   BCat{}        -> BCat x y+                   BSnoc{}       -> BCat x y+                   BCons{}       -> BCat x y++  BSnoc{} -> case y of+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2+                   BNil          -> x+                   BMiddle n     -> BSnoc x n+                   BCat{}        -> BCat x y+                   BSnoc{}       -> BCat x y+                   BCons{}       -> BCat x y+++  BCons{} -> case y of+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2+                   BNil          -> x+                   BMiddle n     -> BSnoc x n+                   BCat{}        -> BCat x y+                   BSnoc{}       -> BCat x y+                   BCons{}       -> BCat x y+++-- -----------------------------------------------------------------------------+-- Mapping++-- | map a function over the nodes of a 'Block'+mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x+mapBlock f (BlockCO n b  ) = BlockCO (f n) (mapBlock f b)+mapBlock f (BlockOC   b n) = BlockOC       (mapBlock f b) (f n)+mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m)+mapBlock _  BNil           = BNil+mapBlock f (BMiddle n)     = BMiddle (f n)+mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)+mapBlock f (BSnoc b n)     = BSnoc   (mapBlock f b)  (f n)+mapBlock f (BCons n b)     = BCons   (f n)  (mapBlock f b)++-- | A strict 'mapBlock'+mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x)+mapBlock' f = mapBlock3' (f, f, f)++-- | map over a block, with different functions to apply to first nodes,+-- middle nodes and last nodes respectively.  The map is strict.+--+mapBlock3' :: forall n n' e x .+             ( 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+mapBlock3' (f, m, l) b = go b+  where go :: forall e x . Block n e x -> Block n' e x+        go (BlockOC b y)   = (BlockOC $! go b) $! l y+        go (BlockCO x b)   = (BlockCO $! f x) $! (go b)+        go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y)+        go BNil            = BNil+        go (BMiddle n)     = BMiddle $! m n+        go (BCat x y)      = (BCat $! go x) $! (go y)+        go (BSnoc x n)     = (BSnoc $! go x) $! (m n)+        go (BCons n x)     = (BCons $! m n) $! (go x)++-- -----------------------------------------------------------------------------+-- Folding+++-- | Fold a function over every node in a block, forward or backward.+-- The fold function must be polymorphic in the shape of the nodes.+foldBlockNodesF3 :: forall n a b c .+                   ( n C O       -> a -> b+                   , n O O       -> b -> b+                   , n O C       -> b -> c)+                 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)+foldBlockNodesF  :: forall n a .+                    (forall e x . n e x       -> a -> a)+                 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)+foldBlockNodesB3 :: forall n a b c .+                   ( n C O       -> b -> c+                   , n O O       -> b -> b+                   , n O C       -> a -> b)+                 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)+foldBlockNodesB  :: forall n a .+                    (forall e x . n e x       -> a -> a)+                 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)++foldBlockNodesF3 (ff, fm, fl) = block+  where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b+        block (BlockCO f b  )   = ff f `cat` block b+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l+        block (BlockOC   b l)   =            block b `cat` fl l+        block BNil              = id+        block (BMiddle node)    = fm node+        block (b1 `BCat`    b2) = block b1 `cat` block b2+        block (b1 `BSnoc` n)    = block b1 `cat` fm n+        block (n `BCons` b2)    = fm n `cat` block b2+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c+        cat f f' = f' . f++foldBlockNodesF f = foldBlockNodesF3 (f, f, f)++foldBlockNodesB3 (ff, fm, fl) = block+  where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b+        block (BlockCO f b  )   = ff f `cat` block b+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l+        block (BlockOC   b l)   =            block b `cat` fl l+        block BNil              = id+        block (BMiddle node)    = fm node+        block (b1 `BCat`    b2) = block b1 `cat` block b2+        block (b1 `BSnoc` n)    = block b1 `cat` fm n+        block (n `BCons` b2)    = fm n `cat` block b2+        cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c+        cat f f' = f . f'++foldBlockNodesB f = foldBlockNodesB3 (f, f, f)+++----------------------------------------------------------------++-- | 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 blk = case blk of+   BlockCO f b   -> BlockCO f (fb b BNil)+   BlockOC   b n -> BlockOC   (fb b BNil) n+   BlockCC f b n -> BlockCC f (fb b BNil) n+   b@BNil{}      -> fb b BNil+   b@BMiddle{}   -> fb b BNil+   b@BCat{}      -> fb b BNil+   b@BSnoc{}     -> fb b BNil+   b@BCons{}     -> fb b BNil+ where+   fb :: Block n O O -> Block n O O -> Block n O O+   fb BNil        rest = rest+   fb (BMiddle n) rest = BCons n rest+   fb (BCat l r)  rest = fb l (fb r rest)+   fb (BCons n b) rest = BCons n (fb b rest)+   fb (BSnoc b n) rest = fb b (BCons n rest)++-- | 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 blk = case blk of+   BlockCO f b   -> BlockCO f (bb BNil b)+   BlockOC   b n -> BlockOC   (bb BNil b) n+   BlockCC f b n -> BlockCC f (bb BNil b) n+   b@BNil{}      -> bb BNil b+   b@BMiddle{}   -> bb BNil b+   b@BCat{}      -> bb BNil b+   b@BSnoc{}     -> bb BNil b+   b@BCons{}     -> bb BNil b+ where+   bb :: Block n O O -> Block n O O -> Block n O O+   bb rest BNil = rest+   bb rest (BMiddle n) = BSnoc rest n+   bb rest (BCat l r) = bb (bb rest l) r+   bb rest (BCons n b) = bb (BSnoc rest n) b+   bb rest (BSnoc b n) = BSnoc (bb rest b) n

@@ -59,6 +59,7 @@   mapEmpty :: map a   mapSingleton :: KeyOf map -> a -> map a   mapInsert :: KeyOf map -> a -> map a -> map a+  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a   mapDelete :: KeyOf map -> map a -> map a    mapUnion :: map a -> map a -> map a@@ -76,6 +77,7 @@   mapKeys :: map a -> [KeyOf map]   mapToList :: map a -> [(KeyOf map, a)]   mapFromList :: [(KeyOf map, a)] -> map a+  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a  -- Helper functions for IsMap class mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a

@@ -19,7 +19,8 @@ import Compiler.Hoopl.Collections import Compiler.Hoopl.Dataflow import Compiler.Hoopl.Fuel-import Compiler.Hoopl.Graph (Graph, C, O, Shape(..))+import Compiler.Hoopl.Block+import Compiler.Hoopl.Graph (Graph) import Compiler.Hoopl.Label  ----------------------------------------------------------------

@@ -1,36 +1,48 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-}+#if __GLASGOW_HASKELL__ >= 703+{- OPTIONS_GHC -fprof-auto #-}+#endif #if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} #endif+#if __GLASGOW_HASKELL__ < 701+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+#endif  module Compiler.Hoopl.Dataflow   ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact, mkFactBase+   , ChangeFlag(..), changeIf-  , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3-  -- * Respecting Fuel -  -- $fuel-  , FwdRewrite,  mkFRewrite,  mkFRewrite3,  getFRewrite3, noFwdRewrite+  , FwdPass(..)+  , FwdTransfer(..), mkFTransfer, mkFTransfer3+  , FwdRewrite(..),  mkFRewrite,  mkFRewrite3, noFwdRewrite   , wrapFR, wrapFR2-  , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3++  , BwdPass(..)+  , BwdTransfer(..), mkBTransfer, mkBTransfer3   , wrapBR, wrapBR2-  , BwdRewrite,  mkBRewrite,  mkBRewrite3,  getBRewrite3, noBwdRewrite+  , BwdRewrite(..),  mkBRewrite,  mkBRewrite3, noBwdRewrite+   , analyzeAndRewriteFwd,  analyzeAndRewriteBwd++  -- * Respecting Fuel++  -- $fuel   ) where -import Control.Monad-import Data.Maybe--import Compiler.Hoopl.Checkpoint+import Compiler.Hoopl.Block import Compiler.Hoopl.Collections+import Compiler.Hoopl.Checkpoint import Compiler.Hoopl.Fuel import Compiler.Hoopl.Graph hiding (Graph) -- hiding so we can redefine                                            -- and include definition in paper-import qualified Compiler.Hoopl.GraphUtil as U import Compiler.Hoopl.Label-import Compiler.Hoopl.Util +import Control.Monad+import Data.Maybe+ ----------------------------------------------------------------------------- --              DataflowLattice -----------------------------------------------------------------------------@@ -93,6 +105,7 @@                     , n O C -> f -> m (Maybe (Graph n O C, FwdRewrite m n f))                     ) } +{-# INLINE wrapFR #-} wrapFR :: (forall e x. (n  e x -> f  -> m  (Maybe (Graph n  e x, FwdRewrite m  n  f )))                     -> (n' e x -> f' -> m' (Maybe (Graph n' e x, FwdRewrite m' n' f')))           )@@ -101,7 +114,9 @@        -> FwdRewrite m  n  f         -> FwdRewrite m' n' f'      -- see Note [Respects Fuel] wrapFR wrap (FwdRewrite3 (f, m, l)) = FwdRewrite3 (wrap f, wrap m, wrap l)-wrapFR2 ++{-# INLINE wrapFR2 #-}+wrapFR2   :: (forall e x . (n1 e x -> f1 -> m1 (Maybe (Graph n1 e x, FwdRewrite m1 n1 f1))) ->                    (n2 e x -> f2 -> m2 (Maybe (Graph n2 e x, FwdRewrite m2 n2 f2))) ->                    (n3 e x -> f3 -> m3 (Maybe (Graph n3 e x, FwdRewrite m3 n3 f3)))@@ -186,7 +201,9 @@ arfGraph :: forall m n f e x .             (NonLocal n, CheckpointMonad m) => FwdPass m n f ->              Entries e -> Graph n e x -> Fact e f -> m (DG f n e x, Fact x f)-arfGraph pass entries = graph+arfGraph pass@FwdPass { fp_lattice = lattice,+                        fp_transfer = transfer,+                        fp_rewrite  = rewrite } 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)@@ -232,21 +249,23 @@      -- Lift from nodes to blocks -- @ start block.tex -2-    block (BFirst  n)  = node n+    block BNil          = \f -> return (dgnil, f)+    block (BlockCO l b)   = node l `cat` block b+    block (BlockCC l b n) = node l `cat` block b `cat` node n+    block (BlockOC   b n) =              block b `cat` node n+     block (BMiddle n)  = node n-    block (BLast   n)  = node n     block (BCat b1 b2) = block b1 `cat` block b2 -- @ end block.tex-    block (BHead h n)  = block h  `cat` node n-    block (BTail n t)  = node  n  `cat` block t-    block (BClosed h t)= block h  `cat` block t+    block (BSnoc h n)  = block h  `cat` node n+    block (BCons n t)  = node  n  `cat` block t  -- @ start node.tex -4     node n f-     = do { grw <- frewrite pass n f+     = do { grw <- frewrite rewrite n f           ; case grw of               Nothing -> return ( singletonDG f n-                                , ftransfer pass n f )+                                , ftransfer transfer n f )               Just (g, rw) ->                   let pass' = pass { fp_rewrite = rw }                       f'    = fwdEntryFact n f@@ -268,7 +287,6 @@          -> (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  @@ -277,11 +295,10 @@                     -- the Body are in the 'DG f n C C' -- @ start bodyfun.tex     body entries blockmap init_fbase-      = fixpoint Fwd lattice do_block blocks init_fbase+      = fixpoint Fwd lattice do_block entries blockmap init_fbase       where-        blocks  = forwardBlockList entries blockmap-        lattice = fp_lattice pass-        do_block :: forall x. Block n C x -> FactBase f -> m (DG f n C x, Fact x f)+        do_block :: forall x. Block n C x -> FactBase f+                 -> m (DG f n C x, Fact x f)         do_block b fb = block b entryFact           where entryFact = getFact lattice (entryLabel b) fb -- @ end bodyfun.tex@@ -323,6 +340,7 @@                     , n O C -> FactBase f -> m (Maybe (Graph n O C, BwdRewrite m n f))                     ) } +{-# INLINE wrapBR #-} wrapBR :: (forall e x .                 Shape x               -> (n  e x -> Fact x f  -> m  (Maybe (Graph n  e x, BwdRewrite m  n  f )))@@ -335,6 +353,7 @@ wrapBR wrap (BwdRewrite3 (f, m, l)) =    BwdRewrite3 (wrap Open f, wrap Open m, wrap Closed l) +{-# INLINE wrapBR2 #-} wrapBR2 :: (forall e x . Shape x             -> (n1 e x -> Fact x f1 -> m1 (Maybe (Graph n1 e x, BwdRewrite m1 n1 f1)))             -> (n2 e x -> Fact x f2 -> m2 (Maybe (Graph n2 e x, BwdRewrite m2 n2 f2)))@@ -387,7 +406,9 @@ arbGraph :: forall m n f e x .             (NonLocal n, CheckpointMonad m) => BwdPass m n f ->              Entries e -> Graph n e x -> Fact x f -> m (DG f n e x, Fact e f)-arbGraph pass entries = graph+arbGraph pass@BwdPass { bp_lattice  = lattice,+                        bp_transfer = transfer,+                        bp_rewrite  = rewrite } 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)@@ -419,23 +440,25 @@              c _ _ = error "bogus GADT pattern match failure"      -- Lift from nodes to blocks-    block (BFirst  n)  = node n+    block BNil          = \f -> return (dgnil, f)+    block (BlockCO l b)   = node l `cat` block b+    block (BlockCC l b n) = node l `cat` block b `cat` node n+    block (BlockOC   b n) =              block b `cat` 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+    block (BSnoc h n)  = block h  `cat` node n+    block (BCons n t)  = node  n  `cat` block t      node n f-      = do { bwdres <- brewrite pass n f+      = do { bwdres <- brewrite rewrite n f            ; case bwdres of                Nothing -> return (singletonDG entry_f n, entry_f)-                            where entry_f = btransfer pass n f+                            where entry_f = btransfer transfer n f                Just (g, rw) ->                           do { let pass' = pass { bp_rewrite = rw }                              ; (g, f) <- arbGraph pass' (fwdEntryLabel n) g f-                             ; return (g, bwdEntryFact (bp_lattice pass) n f)} }+                             ; return (g, bwdEntryFact lattice n f)} }      -- | Compose fact transformers and concatenate the resulting     -- rewritten graphs.@@ -450,7 +473,7 @@          -> (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) $+                          ; let fb = joinInFacts lattice $                                      mapSingleton (entryLabel thing) f                           ; return (rg, fb) }      -- joinInFacts adds debugging information@@ -459,14 +482,14 @@                     -- in the Body; the facts for Labels *in*                     -- the Body are in the 'DG f n C C'     body entries blockmap init_fbase-      = fixpoint Bwd (bp_lattice pass) do_block blocks init_fbase+      = fixpoint Bwd lattice do_block (map entryLabel (backwardBlockList entries blockmap)) blockmap init_fbase       where-        blocks = backwardBlockList entries blockmap         do_block :: forall x. Block n C x -> Fact x f -> m (DG f n C x, LabelMap f)         do_block b f = do (g, f) <- block b f                           return (g, mapSingleton (entryLabel b) f)  + backwardBlockList :: (LabelsPtr entries, NonLocal n) => entries -> Body n -> [Block n C C] -- This produces a list of blocks in order suitable for backward analysis, -- along with the list of Labels it may depend on for facts.@@ -510,23 +533,18 @@ ----------------------------------------------------------------------------- --      fixpoint: finding fixed points -------------------------------------------------------------------------------- @ start txfb.tex-data TxFactBase n f-  = TxFB { tfb_fbase :: FactBase f-         , tfb_rg    :: DG f n C C -- Transformed blocks-         , tfb_cha   :: ChangeFlag-         , tfb_lbls  :: LabelSet }--- @ end txfb.tex+      -- See Note [TxFactBase invariants]--- @ start update.tex-updateFact :: DataflowLattice f -> LabelSet-           -> Label -> f -> (ChangeFlag, FactBase f)-           -> (ChangeFlag, FactBase f)++updateFact :: DataflowLattice f+           -> LabelMap (DBlock f n C C)+           -> Label -> f       -- out fact+           -> ([Label], FactBase f)+           -> ([Label], FactBase f) -- See Note [TxFactBase change flag]-updateFact lat lbls lbl new_fact (cha, fbase)-  | NoChange <- cha2     = (cha,        fbase)-  | lbl `setMember` lbls = (SomeChange, new_fbase)-  | otherwise            = (cha,        new_fbase)+updateFact lat newblocks lbl new_fact (cha, fbase)+  | NoChange <- cha2, lbl `mapMember` newblocks  = (cha,     fbase)+  | otherwise         = (lbl:cha, mapInsert lbl res_fact fbase)   where     (cha2, res_fact) -- Note [Unreachable blocks]        = case lookupFact lbl fbase of@@ -536,8 +554,6 @@                  fact_join lat lbl                    (OldFact old_fact) (NewFact new_fact)                (_, new_fact_debug) = join (fact_bot lat)-    new_fbase = mapInsert lbl res_fact fbase--- @ end update.tex   {-@@ -552,75 +568,63 @@  => Direction  -> DataflowLattice f  -> (Block n C C -> Fact C f -> m (DG f n C C, Fact C f))- -> [Block n C C]+ -> [Label]+ -> LabelMap (Block n C C)  -> (Fact C f -> m (DG f n C C, Fact C f)) -- @ end fptype.tex -- @ start fpimp.tex-fixpoint direction lat do_block blocks init_fbase-  = do { tx_fb <- loop init_fbase-       ; return (tfb_rg tx_fb, -                 map (fst . fst) tagged_blocks -                    `mapDeleteList` tfb_fbase tx_fb ) }-    -- The successors of the Graph are the the Labels +fixpoint direction lat do_block entries blockmap init_fbase+  = do+        -- trace ("fixpoint: " ++ show (case direction of Fwd -> True; Bwd -> False) ++ " " ++ show (mapKeys blockmap) ++ show entries ++ " " ++ show (mapKeys init_fbase)) $ return()+        (fbase, newblocks) <- loop init_fbase entries mapEmpty+        -- trace ("fixpoint DONE: " ++ show (mapKeys fbase) ++ show (mapKeys newblocks)) $ return()+        return (GMany NothingO newblocks NothingO,+                mapDeleteList (mapKeys blockmap) fbase)+    -- The successors of the Graph are the the Labels     -- for which we have facts and which are *not* in     -- the blocks of the graph   where-    tagged_blocks = map tag blocks-    is_fwd = case direction of { Fwd -> True; -                                 Bwd -> False }-    tag :: NonLocal t => t C C -> ((Label, t C C), [Label])-    tag b = ((entryLabel b, b), -             if is_fwd then [entryLabel b] -                        else successors b)-     -- 'tag' adds the in-labels of the block; -     -- see Note [TxFactBase invairants]+    -- mapping from L -> Ls.  If the fact for L changes, re-analyse Ls.+    dep_blocks :: LabelMap [Label]+    dep_blocks = mapFromListWith (++)+                        [ (l, [entryLabel b])+                        | b <- mapElems blockmap+                        , l <- case direction of+                                 Fwd -> [entryLabel b]+                                 Bwd -> successors b+                        ] -    tx_blocks :: [((Label, Block n C C), [Label])]   -- I do not understand this type-              -> TxFactBase n f -> m (TxFactBase n f)-    tx_blocks []              tx_fb = return tx_fb-    tx_blocks (((lbl,blk), in_lbls):bs) tx_fb -      = tx_block lbl blk in_lbls tx_fb >>= tx_blocks bs-     -- "in_lbls" == Labels the block may -     --                 _depend_ upon for facts+    loop+       :: FactBase f  -- current factbase (increases monotonically)+       -> [Label]     -- blocks still to analyse (Todo: use a better rep)+       -> LabelMap (DBlock f n C C)  -- transformed graph+       -> m (FactBase f, LabelMap (DBlock f n C C)) -    tx_block :: Label -> Block n C C -> [Label]-             -> TxFactBase n f -> m (TxFactBase n f)-    tx_block lbl blk in_lbls -        tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls-                    , tfb_rg = blks, tfb_cha = cha })-      | is_fwd && not (lbl `mapMember` fbase)-      = return (tx_fb {tfb_lbls = lbls'})       -- Note [Unreachable blocks]-      | otherwise-      = do { (rg, out_facts) <- do_block blk fbase-           ; let (cha', fbase') = mapFoldWithKey-                                  (updateFact lat lbls')-                                  (cha,fbase) out_facts-           ; return $-               TxFB { tfb_lbls  = lbls'-                    , tfb_rg    = rg `dgSplice` blks-                    , tfb_fbase = fbase'-                    , tfb_cha = cha' } }-      where-        lbls' = lbls `setUnion` setFromList in_lbls-        +    loop fbase []         newblocks = return (fbase, newblocks)+    loop fbase (lbl:todo) newblocks = do+      case mapLookup lbl blockmap of+         Nothing  -> loop fbase todo newblocks+         Just blk -> do+           -- trace ("analysing: " ++ show lbl) $ return ()+           (rg, out_facts) <- do_block blk fbase+           let (changed, fbase') = mapFoldWithKey+                                     (updateFact lat newblocks)+                                     ([],fbase) out_facts+           -- trace ("fbase': " ++ show (mapKeys fbase')) $ return ()+           -- trace ("changed: " ++ show changed) $ return ()+     +           let to_analyse+                 = filter (`notElem` todo) $+                   concatMap (\l -> mapFindWithDefault [] l dep_blocks) changed -    loop :: FactBase f -> m (TxFactBase n f)-    loop fbase -      = do { s <- checkpoint-           ; let init_tx :: TxFactBase n f-                 init_tx = TxFB { tfb_fbase = fbase-                                , tfb_cha   = NoChange-                                , tfb_rg    = dgnilC-                                , tfb_lbls  = setEmpty }-           ; tx_fb <- tx_blocks tagged_blocks init_tx-           ; case tfb_cha tx_fb of-               NoChange   -> return tx_fb-               SomeChange -                 -> do { restart s-                       ; loop (tfb_fbase tx_fb) } }--- @ end fpimp.tex           +           -- trace ("to analyse: " ++ show to_analyse) $ return () +           let newblocks' = case rg of+                              GMany _ blks _ -> mapUnion blks newblocks+     +           loop fbase' (todo ++ to_analyse) newblocks' + {-  Note [TxFactBase invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The TxFactBase is used only during a fixpoint iteration (or "sweep"),@@ -712,14 +716,13 @@  ---- observers -type GraphWithFacts n f e x = (Graph n e x, FactBase f)-  -- A Graph together with the facts for that graph-  -- The domains of the two maps should be identical- normalizeGraph :: forall n f e x .-                  NonLocal n => DG f n e x -> GraphWithFacts n f e x+                  NonLocal n => DG f n e x+               -> (Graph n e x, FactBase f)+                 -- A Graph together with the facts for that graph+                 -- The domains of the two maps should be identical -normalizeGraph g = (graphMapBlocks dropFact g, facts g)+normalizeGraph g = (mapGraphBlocks dropFact g, facts g)     where dropFact :: DBlock t t1 t2 t3 -> Block t1 t2 t3           dropFact (DBlock _ b) = b           facts :: DG f n e x -> FactBase f@@ -730,18 +733,18 @@           exitFacts NothingO = noFacts           exitFacts (JustO (DBlock f b)) = mapSingleton (entryLabel b) f           bodyFacts :: LabelMap (DBlock f n C C) -> FactBase f-          bodyFacts body = mapFold f noFacts body-            where f :: forall t a x. (NonLocal t) => DBlock a t C x -> LabelMap a -> LabelMap a-                  f (DBlock f b) fb = mapInsert (entryLabel b) f fb+          bodyFacts body = mapFoldWithKey f noFacts body+            where f :: forall t a x. (NonLocal t) => Label -> DBlock a t C x -> LabelMap a -> LabelMap a+                  f lbl (DBlock f _) fb = mapInsert lbl f fb  --- implementation of the constructors (boring)  dgnil  = GNil dgnilC = GMany NothingO emptyBody NothingO -dgSplice = U.splice fzCat+dgSplice = splice fzCat   where fzCat :: DBlock f n e O -> DBlock t n O x -> DBlock f n e x-        fzCat (DBlock f b1) (DBlock _ b2) = DBlock f (b1 `U.cat` b2)+        fzCat (DBlock f b1) (DBlock _ b2) = DBlock f (b1 `blockAppend` b2)  ---------------------------------------------------------------- --       Utilities@@ -758,43 +761,43 @@  singletonDG   :: f -> n e x -> DG f n e x  fwdEntryFact  :: NonLocal n => n e x -> f -> Fact e f  fwdEntryLabel :: NonLocal n => n e x -> MaybeC e [Label]- ftransfer :: FwdPass m n f -> n e x -> f -> Fact x f- frewrite  :: FwdPass m n f -> n e x + ftransfer :: FwdTransfer n f -> n e x -> f -> Fact x f+ frewrite  :: FwdRewrite m n f -> n e x            -> f -> m (Maybe (Graph n e x, FwdRewrite m n f)) -- @ end node.tex  bwdEntryFact :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f- btransfer    :: BwdPass m n f -> n e x -> Fact x f -> f- brewrite     :: BwdPass m n f -> n e x+ btransfer    :: BwdTransfer n f -> n e x -> Fact x f -> f+ brewrite     :: BwdRewrite m n f -> n e x               -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f))  instance ShapeLifter C O where-  singletonDG f = gUnitCO . DBlock f . BFirst+  singletonDG f n = gUnitCO (DBlock f (BlockCO n BNil))   fwdEntryFact     n f  = mapSingleton (entryLabel n) f   bwdEntryFact lat n fb = getFact lat (entryLabel n) fb-  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (ft, _, _)}) n f = ft n f-  btransfer (BwdPass {bp_transfer = BwdTransfer3 (bt, _, _)}) n f = bt n f-  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (fr, _, _)}) n f = fr n f-  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (br, _, _)}) n f = br n f+  ftransfer (FwdTransfer3 (ft, _, _)) n f = ft n f+  btransfer (BwdTransfer3 (bt, _, _)) n f = bt n f+  frewrite  (FwdRewrite3  (fr, _, _)) n f = fr n f+  brewrite  (BwdRewrite3  (br, _, _)) n f = br n f   fwdEntryLabel n = JustC [entryLabel n]  instance ShapeLifter O O where   singletonDG f = gUnitOO . DBlock f . BMiddle   fwdEntryFact   _ f = f   bwdEntryFact _ _ f = f-  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, ft, _)}) n f = ft n f-  btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, bt, _)}) n f = bt n f-  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (_, fr, _)}) n f = fr n f-  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (_, br, _)}) n f = br n f+  ftransfer (FwdTransfer3 (_, ft, _)) n f = ft n f+  btransfer (BwdTransfer3 (_, bt, _)) n f = bt n f+  frewrite  (FwdRewrite3  (_, fr, _)) n f = fr n f+  brewrite  (BwdRewrite3  (_, br, _)) n f = br n f   fwdEntryLabel _ = NothingC  instance ShapeLifter O C where-  singletonDG f = gUnitOC . DBlock f . BLast+  singletonDG f n = gUnitOC (DBlock f (BlockOC BNil n))   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+  ftransfer (FwdTransfer3 (_, _, ft)) n f = ft n f+  btransfer (BwdTransfer3 (_, _, bt)) n f = bt n f+  frewrite  (FwdRewrite3  (_, _, fr)) n f = fr n f+  brewrite  (BwdRewrite3  (_, _, br)) n f = br n f   fwdEntryLabel _ = NothingC  -- Fact lookup: the fact `orelse` bottom

@@ -1,27 +0,0 @@-{-# LANGUAGE GADTs, RankNTypes #-}-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Safe #-}-#endif--{- 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,98 +1,102 @@-{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies, Rank2Types #-}+{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies, ScopedTypeVariables,+    RankNTypes, FlexibleInstances, TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif+#if __GLASGOW_HASKELL__ < 701+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+#endif  module Compiler.Hoopl.Graph -  ( O, C, Block(..), Body, Body'(..), Graph, Graph'(..)-  , MaybeO(..), MaybeC(..), Shape(..), IndexedCO+  (+    -- * Body+    Body, Body', emptyBody, bodyList, addBlock, bodyUnion++    -- * Graph+  , Graph, Graph'(..)   , NonLocal(entryLabel, successors)-  , emptyBody, addBlock, bodyList-  , mapGraph, mapMaybeO, mapMaybeC, mapBlock++  -- ** Constructing graphs+  , bodyGraph+  , blockGraph+  , gUnitOO, gUnitOC, gUnitCO, gUnitCC+  , catGraphNodeOC, catGraphNodeOO+  , catNodeCOGraph, catNodeOOGraph++  -- ** Splicing graphs+  , splice, gSplice++  -- ** Maps+  , mapGraph, mapGraphBlocks++  -- ** Folds+  , foldGraphNodes++  -- ** Extracting Labels+  , labelsDefined, labelsUsed, externalEntryLabels++  -- ** Depth-first traversals+  , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except+  , preorder_dfs, preorder_dfs_from_except+  , LabelsPtr(..)   ) where  import Compiler.Hoopl.Collections+import Compiler.Hoopl.Block import Compiler.Hoopl.Label ---------------------------------------------------------------------------------		Graphs------------------------------------------------------------------------------+import Control.Monad --- | Used at the type level to indicate an "open" structure with    --- a unique, unnamed control-flow edge flowing in or out.         --- "Fallthrough" and concatenation are permitted at an open point.-data O -       -       --- | Used at the type level to indicate a "closed" structure which--- supports control transfer only through the use of named--- labels---no "fallthrough" is permitted.  The number of control-flow--- edges is unconstrained.-data C --- | A sequence of nodes.  May be any of four shapes (O/O, O/C, C/O, C/C).--- Open at the entry means single entry, mutatis mutandis for exit.--- A closed/closed block is a /basic/ block and can't be extended further.--- Clients should avoid manipulating blocks and should stick to either nodes--- or graphs.-data Block n e x where-  -- nodes-  BFirst  :: n C O                 -> Block n C O -- x^ block holds a single first node-  BMiddle :: n O O                 -> Block n O O -- x^ block holds a single middle node-  BLast   :: n O C                 -> Block n O C -- x^ block holds a single last node--  -- concatenation operations-  BCat    :: Block n O O -> Block n O O -> Block n O O -- non-list-like-  BHead   :: Block n C O -> n O O       -> Block n C O-  BTail   :: n O O       -> Block n O C -> Block n O C  --  BClosed :: Block n C O -> Block n O C -> Block n C C -- the zipper+-- -----------------------------------------------------------------------------+-- Body  -- | A (possibly empty) collection of closed/closed blocks type Body n = LabelMap (Block n C C)-newtype Body' block n = Body (LabelMap (block n C C)) --- | A control-flow graph, which may take any of four shapes (O/O, O/C, C/O, C/C).--- A graph open at the entry has a single, distinguished, anonymous entry point;--- if a graph is closed at the entry, its entry point(s) are supplied by a context.-type Graph = Graph' Block-data Graph' block (n :: * -> * -> *) e x where-  GNil  :: Graph' block n O O-  GUnit :: block n O O -> Graph' block n O O-  GMany :: MaybeO e (block n O C) -        -> LabelMap (block n C C)-        -> MaybeO x (block n C O)-        -> Graph' block n e x+-- | @Body@ abstracted over @block@+type Body' block (n :: * -> * -> *) = LabelMap (block n C C) --- | Maybe type indexed by open/closed-data MaybeO ex t where-  JustO    :: t -> MaybeO O t-  NothingO ::      MaybeO C t+emptyBody :: Body' block n+emptyBody = mapEmpty --- | Maybe type indexed by closed/open-data MaybeC ex t where-  JustC    :: t -> MaybeC C t-  NothingC ::      MaybeC O t+bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a+bodyUnion = mapUnionWithKey nodups+  where nodups l _ _ = error $ "duplicate blocks with label " ++ show l --- | Dynamic shape value-data Shape ex where-  Closed :: Shape C-  Open   :: Shape O+bodyList :: NonLocal (block n) => Body' block n -> [(Label,block n C C)]+bodyList body = mapToList body --- | Either type indexed by closed/open using type families-type family IndexedCO ex a b :: *-type instance IndexedCO C a b = a-type instance IndexedCO O a b = b+addBlock :: NonLocal thing+         => thing C C -> LabelMap (thing C C)+         -> LabelMap (thing C C)+addBlock b body+  | mapMember lbl body = error $ "duplicate label " ++ show lbl ++ " in graph"+  | otherwise          = mapInsert lbl b body+  where lbl = entryLabel b -instance Functor (MaybeO ex) where-  fmap _ NothingO = NothingO-  fmap f (JustO a) = JustO (f a) -instance Functor (MaybeC ex) where-  fmap _ NothingC = NothingC-  fmap f (JustC a) = JustC (f a)+-- ---------------------------------------------------------------------------+-- Graph +-- | 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++-- | @Graph'@ is abstracted over the block type, so that we can build+-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow+-- needs this).+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+        -> MaybeO x (block n C O)+        -> Graph' block n e x+ ------------------------------- -- | Gives access to the anchor points for -- nonlocal edges as well as the edges themselves@@ -101,49 +105,310 @@   successors :: thing e C -> [Label] -- ^ Gives control-flow successors  instance NonLocal n => NonLocal (Block n) where-  entryLabel (BFirst n)    = entryLabel n-  entryLabel (BHead h _)   = entryLabel h-  entryLabel (BClosed h _) = entryLabel h-  successors (BLast n)     = successors n-  successors (BTail _ t)   = successors t-  successors (BClosed _ t) = successors t+  entryLabel (BlockCO f _)   = entryLabel f+  entryLabel (BlockCC f _ _) = entryLabel f --------------------------------emptyBody :: LabelMap (thing C C)-emptyBody = mapEmpty+  successors (BlockOC   _ n) = successors n+  successors (BlockCC _ _ n) = successors n -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+-- -----------------------------------------------------------------------------+-- Constructing graphs +bodyGraph :: Body n -> Graph n C C+bodyGraph b = GMany NothingO b NothingO++gUnitOO :: block n O O -> Graph' block n O O+gUnitOC :: block n O C -> Graph' block n O C+gUnitCO :: block n C O -> Graph' block n C O+gUnitCC :: NonLocal (block n) => block n C C -> Graph' block n C C+gUnitOO b = GUnit b+gUnitOC b = GMany (JustO b) emptyBody  NothingO+gUnitCO b = GMany NothingO  emptyBody (JustO b)+gUnitCC b = GMany NothingO (addBlock b emptyBody) NothingO+++catGraphNodeOO ::               Graph n e O -> n O O -> Graph n e O+catGraphNodeOC :: NonLocal n => Graph n e O -> n O C -> Graph n e C+catNodeOOGraph ::               n O O -> Graph n O x -> Graph n O x+catNodeCOGraph :: NonLocal n => n C O -> Graph n O x -> Graph n C x++catGraphNodeOO GNil                     n = gUnitOO $ BMiddle n+catGraphNodeOO (GUnit b)                n = gUnitOO $ BSnoc b n+catGraphNodeOO (GMany e body (JustO (BlockCO f b))) n+  = GMany e body (JustO (BlockCO f (BSnoc b n)))++catGraphNodeOC GNil                     n = gUnitOC $ BlockOC BNil n+catGraphNodeOC (GUnit b)                n = gUnitOC $ BlockOC b n+catGraphNodeOC (GMany e body (JustO (BlockCO f x))) n+  = GMany e (addBlock (BlockCC f x n) body) NothingO++catNodeOOGraph n GNil                     = gUnitOO $ BMiddle n+catNodeOOGraph n (GUnit b)                = gUnitOO $ BCons n b+catNodeOOGraph n (GMany (JustO (BlockOC b l)) body x)+   = GMany (JustO (BlockOC (n `BCons` b) l)) body x++catNodeCOGraph f GNil                     = gUnitCO (BlockCO f BNil)+catNodeCOGraph f (GUnit b)                = gUnitCO (BlockCO f b)+catNodeCOGraph f (GMany (JustO (BlockOC b n)) body x)+  = GMany NothingO (addBlock (BlockCC f b n) body) x+++blockGraph :: NonLocal n => Block n e x -> Graph n e x+blockGraph b@(BlockCO {}) = gUnitCO b+blockGraph b@(BlockOC {}) = gUnitOC b+blockGraph b@(BlockCC {}) = gUnitCC b+blockGraph   (BNil  {})   = GNil+blockGraph b@(BMiddle {}) = gUnitOO b+blockGraph b@(BCat {})    = gUnitOO b+blockGraph b@(BSnoc {})   = gUnitOO b+blockGraph b@(BCons {})   = gUnitOO b+++-- -----------------------------------------------------------------------------+-- Splicing graphs++splice :: forall block n e a x . NonLocal (block n) =>+          (forall e x . block n e O -> block n O x -> block n e x)+       -> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x)++splice bcat = sp+  where sp :: forall e a x .+              Graph' block n e a -> Graph' block n a x -> Graph' block n e x++        sp GNil g2 = g2+        sp g1 GNil = g1++        sp (GUnit b1) (GUnit b2) = {-# SCC "sp1" #-} GUnit $! b1 `bcat` b2++        sp (GUnit b) (GMany (JustO e) bs x) = {-# SCC "sp2" #-} GMany (JustO (b `bcat` e)) bs x++        sp (GMany e bs (JustO x)) (GUnit b2) = {-# SCC "sp3" #-} x `seq` GMany e bs (JustO x')+             where x' = x `bcat` b2++        sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2)+          = {-# SCC "sp4" #-} (GMany e1 $! b1 `bodyUnion` b2) x2+          where b1   = (addBlock $! x1 `bcat` e2) bs1++        sp (GMany e1 b1 NothingO) (GMany NothingO b2 x2)+          = {-# SCC "sp5" #-} (GMany e1 $! b1 `bodyUnion` b2) x2++        sp _ _ = error "bogus GADT match failure"++gSplice :: NonLocal n => Graph n e a -> Graph n a x -> Graph n e x+gSplice = splice blockAppend+++-- -----------------------------------------------------------------------------+-- Mapping over graphs+ -- | Maps over all nodes in a graph. mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x-mapGraph _ GNil = GNil-mapGraph f (GUnit b) = GUnit (mapBlock f b)-mapGraph f (GMany x y z)-    = GMany (mapMaybeO f x)-            (mapMap (mapBlock f) y)-            (mapMaybeO f z)+mapGraph f = mapGraphBlocks (mapBlock f) -mapMaybeO :: (forall e x. n e x -> n' e x) -> MaybeO ex (Block n e x) -> MaybeO ex (Block n' e x)-mapMaybeO _  NothingO = NothingO-mapMaybeO f (JustO b) = JustO (mapBlock f b)+-- | Function 'mapGraphBlocks' 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.+mapGraphBlocks :: 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) -mapMaybeC :: (forall e x. n e x -> n' e x) -> MaybeC ex (Block n e x) -> MaybeC ex (Block n' e x)-mapMaybeC _  NothingC = NothingC-mapMaybeC f (JustC b) = JustC (mapBlock f b)+mapGraphBlocks f = map+  where map :: Graph' block n e x -> Graph' block' n' e x+        map GNil = GNil+        map (GUnit b) = GUnit (f b)+        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x) -mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x-mapBlock f (BFirst n)      = BFirst  (f n)-mapBlock f (BMiddle n)     = BMiddle (f n)-mapBlock f (BLast n)       = BLast   (f n)-mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)-mapBlock f (BHead b n)     = BHead   (mapBlock f b)  (f n)-mapBlock f (BTail n b)     = BTail   (f n)  (mapBlock f b)-mapBlock f (BClosed b1 b2) = BClosed (mapBlock f b1) (mapBlock f b2)++-- -----------------------------------------------------------------------------+-- Folds++-- | 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)++foldGraphNodes f = graph+    where graph :: forall e x . Graph n e x -> a -> a+          lift  :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a)++          graph GNil              = id+          graph (GUnit b)         = block b+          graph (GMany e b x)     = lift block e . body b . lift block x+          body :: Body n -> a -> a+          body bdy                = \a -> mapFold block a bdy+          lift _ NothingO         = id+          lift f (JustO thing)    = f thing++          block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a+          block = foldBlockNodesF f+++----------------------------------------------------------------++class LabelsPtr l where+  targetLabels :: l -> [Label]++instance NonLocal n => LabelsPtr (n e C) where+  targetLabels n = successors n++instance LabelsPtr Label where+  targetLabels l = [l]++instance LabelsPtr LabelSet where+  targetLabels = setElems++instance LabelsPtr l => LabelsPtr [l] where+  targetLabels = concatMap targetLabels+++-- | Traversal: 'postorder_dfs' returns a list of blocks reachable+-- from the entry of enterable graph. The entry and exit are *not* included.+-- The list has the following property:+--+--	Say a "back reference" exists if one of a block's+--	control-flow successors precedes it in the output list+--+--	Then there are as few back references as possible+--+-- The output is suitable for use in+-- a forward dataflow problem.  For a backward problem, simply reverse+-- the list.  ('postorder_dfs' is sufficiently tricky to implement that+-- one doesn't want to try and maintain both forward and backward+-- versions.)++postorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C]+preorder_dfs  :: NonLocal (block n) => Graph' block n O x -> [block n C C]++-- | This is the most important traversal over this data structure.  It drops+-- unreachable code and puts blocks in an order that is good for solving forward+-- dataflow problems quickly.  The reverse order is good for solving backward+-- dataflow problems quickly.  The forward order is also reasonably good for+-- emitting instructions, except that it will not usually exploit Forrest+-- Baskett's trick of eliminating the unconditional branch from a loop.  For+-- that you would need a more serious analysis, probably based on dominators, to+-- identify loop headers.+--+-- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'+-- representation, when for most purposes the plain 'Graph' representation is+-- more mathematically elegant (but results in more complicated code).+--+-- Here's an easy way to go wrong!  Consider+-- @+--	A -> [B,C]+--	B -> D+--	C -> D+-- @+-- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.+-- Better to get [A,B,C,D]+++graphDfs :: (NonLocal (block n))+         => (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C])+         -> (Graph' block n O x -> [block n C C])+graphDfs _     (GNil)    = []+graphDfs _     (GUnit{}) = []+graphDfs order (GMany (JustO entry) body _) = order body entry setEmpty++postorder_dfs = graphDfs postorder_dfs_from_except+preorder_dfs  = graphDfs preorder_dfs_from_except++postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)+                          => LabelMap (block C C) -> e -> LabelSet -> [block C C]+postorder_dfs_from_except blocks b visited =+ vchildren (get_children b) (\acc _visited -> acc) [] visited+ where+   vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a+   vnode block cont acc visited =+        if setMember id visited then+            cont acc visited+        else+            let cont' acc visited = cont (block:acc) visited in+            vchildren (get_children block) cont' acc (setInsert id visited)+      where id = entryLabel block+   vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a+   vchildren bs cont acc visited = next bs acc visited+      where next children acc visited =+                case children of []     -> cont acc visited+                                 (b:bs) -> vnode b (next bs) acc visited+   get_children :: forall l. LabelsPtr l => l -> [block C C]+   get_children block = foldr add_id [] $ targetLabels block+   add_id id rst = case lookupFact id blocks of+                      Just b -> b : rst+                      Nothing -> rst++postorder_dfs_from+    :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]+postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty+++----------------------------------------------------------------++data VM a = VM { unVM :: LabelSet -> (a, LabelSet) }+marked :: Label -> VM Bool+mark   :: Label -> VM ()+instance Monad VM where+  return a = VM $ \visited -> (a, visited)+  m >>= k  = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v'+marked l = VM $ \v -> (setMember l v, v)+mark   l = VM $ \v -> ((), setInsert l v)++preorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)+                         => LabelMap (block C C) -> e -> LabelSet -> [block C C]+preorder_dfs_from_except blocks b visited =+    (fst $ unVM (children (get_children b)) visited) []+  where children [] = return id+        children (b:bs) = liftM2 (.) (visit b) (children bs)+        visit :: block C C -> VM (HL (block C C))+        visit b = do already <- marked (entryLabel b)+                     if already then return id+                      else do mark (entryLabel b)+                              bs <- children $ get_children b+                              return $ b `cons` bs+        get_children :: forall l. LabelsPtr l => l -> [block C C]+        get_children block = foldr add_id [] $ targetLabels block++        add_id id rst = case lookupFact id blocks of+                          Just b -> b : rst+                          Nothing -> rst++type HL a = [a] -> [a] -- Hughes list (constant-time concatenation)+cons :: a -> HL a -> HL a+cons a as tail = a : as tail+++-- -----------------------------------------------------------------------------+-- Extracting Labels from graphs++labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x+              -> LabelSet+labelsDefined GNil      = setEmpty+labelsDefined (GUnit{}) = setEmpty+labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body+  where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet+        addEntry label _ labels = setInsert label labels+        exitLabel :: MaybeO x (block n C O) -> LabelSet+        exitLabel NothingO  = setEmpty+        exitLabel (JustO b) = setSingleton (entryLabel b)++labelsUsed :: forall block n e x. NonLocal (block n) => Graph' block n e x+           -> LabelSet+labelsUsed GNil      = setEmpty+labelsUsed (GUnit{}) = setEmpty+labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body +  where addTargets :: forall e. block n e C -> LabelSet -> LabelSet+        addTargets block labels = setInsertList (successors block) labels+        entryTargets :: MaybeO e (block n O C) -> LabelSet+        entryTargets NothingO = setEmpty+        entryTargets (JustO b) = addTargets b setEmpty++externalEntryLabels :: forall n .+                       NonLocal n => LabelMap (Block n C C) -> LabelSet+externalEntryLabels body = defined `setDifference` used+  where defined = labelsDefined g+        used = labelsUsed g+        g = GMany NothingO body NothingO+

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

@@ -0,0 +1,18 @@+{-# LANGUAGE GADTs, RankNTypes #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Safe #-}+#endif++{- Exposing some internals to friends (e.g. GHC) -}+module Compiler.Hoopl.Internals+  ( module Compiler.Hoopl.Block+  , module Compiler.Hoopl.Graph+  , module Compiler.Hoopl.Label+  , module Compiler.Hoopl.Dataflow+  )+where++import Compiler.Hoopl.Block+import Compiler.Hoopl.Graph+import Compiler.Hoopl.Label+import Compiler.Hoopl.Dataflow

@@ -78,6 +78,7 @@   mapEmpty = LM mapEmpty   mapSingleton (Label k) v = LM (mapSingleton k v)   mapInsert (Label k) v (LM m) = LM (mapInsert k v m)+  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)   mapDelete (Label k) (LM m) = LM (mapDelete k m)    mapUnion (LM x) (LM y) = LM (mapUnion x y)@@ -95,6 +96,7 @@   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])+  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])  ----------------------------------------------------------------------------- -- FactBase

@@ -15,8 +15,8 @@ where  import Compiler.Hoopl.Label (Label, uniqueToLbl)-import Compiler.Hoopl.Graph-import qualified Compiler.Hoopl.GraphUtil as U+import Compiler.Hoopl.Block+import Compiler.Hoopl.Graph as U import Compiler.Hoopl.Unique import Control.Monad (liftM2) @@ -70,8 +70,8 @@   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+  mkFirst n = mkExit (BlockCO n BNil)+  mkLast  n = mkEntry (BlockOC BNil n)   infixl 3 <*>   infixl 2 |*><*|    -- | Concatenate two graphs; control flows from left to right.

@@ -12,7 +12,7 @@   ) where -import Compiler.Hoopl.Graph+import Compiler.Hoopl.Block import Compiler.Hoopl.Label import Compiler.Hoopl.Dataflow 

@@ -9,6 +9,7 @@ where  import Compiler.Hoopl.Collections+import Compiler.Hoopl.Block import Compiler.Hoopl.Graph import Compiler.Hoopl.Label @@ -28,13 +29,14 @@             open b g_entry ++ body g_blocks ++ open b g_exit         body blocks = concatMap b (mapElems blocks)         b :: forall e x . Block n e x -> String-        b (BFirst  n)     = node n-        b (BMiddle n)     = node n-        b (BLast   n)     = node n ++ "\n"+        b (BlockCO l b1)   = node l ++ "\n" ++ b b1+        b (BlockCC l b1 n) = node l ++ "\n" ++ b b1 ++ node n ++ "\n"+        b (BlockOC   b1 n) =           b b1 ++ node n ++ "\n"+        b (BNil)          = ""+        b (BMiddle 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+        b (BSnoc b1 n)    = b b1   ++ node n ++ "\n"+        b (BCons n b1)    = node n ++ "\n" ++ b b1  open :: (a -> String) -> MaybeO z a -> String open _ NothingO  = ""

@@ -25,14 +25,13 @@ --		Unique ----------------------------------------------------------------------------- -data Unique = Unique { uniqueToInt ::  {-# UNPACK #-} !Int }-  deriving (Eq, Ord)+type Unique = Int -intToUnique :: Int -> Unique-intToUnique = Unique+uniqueToInt :: Unique -> Int+uniqueToInt = id -instance Show Unique where-  show (Unique n) = show n+intToUnique :: Int -> Unique+intToUnique = id  ----------------------------------------------------------------------------- -- UniqueSet@@ -44,22 +43,22 @@    setNull (US s) = S.null s   setSize (US s) = S.size s-  setMember (Unique k) (US s) = S.member k s+  setMember 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)+  setSingleton k = US (S.singleton k)+  setInsert k (US s) = US (S.insert k s)+  setDelete 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+  setFold k z (US s) = S.fold k z s -  setElems (US s) = map intToUnique (S.elems s)-  setFromList ks = US (S.fromList (map uniqueToInt ks))+  setElems (US s) = S.elems s+  setFromList ks = US (S.fromList ks)  ----------------------------------------------------------------------------- -- UniqueMap@@ -71,14 +70,15 @@    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+  mapMember k (UM m) = M.member k m+  mapLookup k (UM m) = M.lookup k m+  mapFindWithDefault def 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)+  mapSingleton k v = UM (M.singleton k v)+  mapInsert k v (UM m) = UM (M.insert k v m)+  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)+  mapDelete 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)@@ -92,9 +92,10 @@   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])+  mapKeys (UM m) = M.keys m+  mapToList (UM m) = M.toList m+  mapFromList assocs = UM (M.fromList assocs)+  mapFromListWith f assocs = UM (M.fromListWith f assocs)  ---------------------------------------------------------------- -- Monads@@ -139,4 +140,4 @@ runUniqueMonadT m = do { (a, _) <- unUMT m allUniques; return a }  allUniques :: [Unique]-allUniques = map Unique [1..]+allUniques = [1..]

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

@@ -6,38 +6,30 @@ -- | Utilities for clients of Hoopl, not used internally.  module Compiler.Hoopl.XUtil-  ( firstXfer, distributeXfer+  (+    -- * Utilities for clients+    firstXfer, distributeXfer   , distributeFact, distributeFactBwd   , successorFacts   , joinFacts   , joinOutFacts -- deprecated   , joinMaps-  , foldGraphNodes-  , foldBlockNodesF, foldBlockNodesB, foldBlockNodesF3, foldBlockNodesB3-  , tfFoldBlock-  , ScottBlock(ScottBlock), scottFoldBlock-  , fbnf3-  , blockToNodeList, blockOfNodeList-  , blockToNodeList'   -- alternate version using fold-  , blockToNodeList''  -- alternate version using scottFoldBlock-  , blockToNodeList''' -- alternate version using tfFoldBlock   , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody   , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx-  , noEntries-  , BlockResult(..), lookupBlock   ) where  import qualified Data.Map as M import Data.Maybe -import Compiler.Hoopl.Checkpoint import Compiler.Hoopl.Collections+import Compiler.Hoopl.Checkpoint import Compiler.Hoopl.Dataflow+import Compiler.Hoopl.Block 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@@ -127,6 +119,7 @@ distributeXfer lattice xfer n f =     mkFactBase lattice [ (l, xfer n f) | l <- successors n ] + -- | This utility function handles a common case in which a transfer function -- for a last node takes the incoming fact unchanged and simply distributes -- that fact over the outgoing edges.@@ -174,338 +167,3 @@   --- | A fold function that relies on the IndexedCO type function.---   Note that the type parameter e is available to the functions---   that are applied to the middle and last nodes.-tfFoldBlock :: forall n bc bo c e x .-               ( n C O -> bc-               , n O O -> IndexedCO e bc bo -> IndexedCO e bc bo-               , n O C -> IndexedCO e bc bo -> c)-            -> (Block n e x -> bo -> IndexedCO x c (IndexedCO e bc bo))-tfFoldBlock (f, m, l) bl bo = block bl-  where block :: forall x . Block n e x -> IndexedCO x c (IndexedCO e bc bo)-        block (BFirst  n)       = f n-        block (BMiddle n)       = m n bo-        block (BLast   n)       = l n bo-        block (b1 `BCat`    b2) = oblock b2 $ block b1-        block (b1 `BClosed` b2) = oblock b2 $ block b1-        block (b1 `BHead` n)    = m n $ block b1-        block (n `BTail` b2)    = oblock b2 $ m n bo-        oblock :: forall x . Block n O x -> IndexedCO e bc bo -> IndexedCO x c (IndexedCO e bc bo)-        oblock (BMiddle n)       = m n-        oblock (BLast   n)       = l n-        oblock (b1 `BCat`    b2) = oblock b1 `cat` oblock b2-        oblock (n `BTail` b2)    = m n       `cat` oblock b2-        cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c-        cat f f' = f' . f---type NodeList' e x n = (MaybeC e (n C O), [n O O], MaybeC x (n O C))-blockToNodeList''' ::-  forall n e x. ( IndexedCO e (NodeList' C O n) (NodeList' O O n) ~ NodeList' e O n-                , IndexedCO x (NodeList' e C n) (NodeList' e O n) ~ NodeList' e x n) =>-    Block n e x -> NodeList' e x n-blockToNodeList''' b = (h, reverse ms', t)-  where-    (h, ms', t) = tfFoldBlock (f, m, l) b z-    z :: NodeList' O O n-    z = (NothingC, [], NothingC)-    f :: n C O -> NodeList' C O n-    f n = (JustC n,  [], NothingC)-    m n (h, ms', t) = (h, n : ms', t)-    l n (h, ms', _) = (h, ms', JustC n)---{--data EitherCO' ex a b where-  LeftCO  :: a -> EitherCO' C a b-  RightCO :: b -> EitherCO' O a b--}--  -- should be done with a *backward* fold---- | More general fold--_unused :: Int-_unused = 3-  where _a = foldBlockNodesF3'' (Trips undefined undefined undefined)-        _b = foldBlockNodesF3'--data Trips n a b c = Trips { ff :: forall e . MaybeC e (n C O) -> a -> b-                           , fm :: n O O            -> b -> b-                           , fl :: forall x . MaybeC x (n O C) -> b -> c-                           }--foldBlockNodesF3'' :: forall n a b c .-                      Trips n a b c -> (forall e x . Block n e x -> a -> c)-foldBlockNodesF3'' trips = block-  where block :: Block n e x -> a -> c-        block (b1 `BClosed` b2) = foldCO b1 `cat` foldOC b2-        block (BFirst  node)    = ff trips (JustC node)  `cat` missingLast-        block (b @ BHead {})    = foldCO b `cat` missingLast-        block (BMiddle node)    = missingFirst `cat` fm trips node  `cat` missingLast-        block (b @ BCat {})     = missingFirst `cat` foldOO b `cat` missingLast-        block (BLast   node)    = missingFirst `cat` fl trips (JustC node)-        block (b @ BTail {})    = missingFirst `cat` foldOC b-        missingLast = fl trips NothingC-        missingFirst = ff trips NothingC-        foldCO :: Block n C O -> a -> b-        foldOO :: Block n O O -> b -> b-        foldOC :: Block n O C -> b -> c-        foldCO (BFirst n)   = ff trips (JustC n)-        foldCO (BHead b n)  = foldCO b `cat` fm trips n-        foldOO (BMiddle n)  = fm trips n-        foldOO (BCat b1 b2) = foldOO b1 `cat` foldOO b2-        foldOC (BLast n)    = fl trips (JustC n)-        foldOC (BTail n b)  = fm trips n `cat` foldOC b-        cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c-        f `cat` g = g . f --data ScottBlock n a = ScottBlock-   { sb_first :: n C O -> a C O-   , sb_mid   :: n O O -> a O O-   , sb_last  :: n O C -> a O C-   , sb_cat   :: forall e x . a e O -> a O x -> a e x-   }--scottFoldBlock :: forall n a e x . ScottBlock n a -> Block n e x -> a e x-scottFoldBlock funs = block-  where block :: forall e x . Block n e x -> a e x-        block (BFirst n)  = sb_first  funs n-        block (BMiddle n) = sb_mid    funs n-        block (BLast   n) = sb_last   funs n-        block (BClosed b1 b2) = block b1 `cat` block b2-        block (BCat    b1 b2) = block b1 `cat` block b2-        block (BHead   b  n)  = block b  `cat` sb_mid funs n-        block (BTail   n  b)  = sb_mid funs n `cat` block b-        cat :: forall e x. a e O -> a O x -> a e x-        cat = sb_cat funs--newtype NodeList n e x-    = NL { unList :: (MaybeC e (n C O), [n O O] -> [n O O], MaybeC x (n O C)) }--fbnf3 :: forall n a b c .-         ( n C O       -> a -> b-         , n O O       -> b -> b-         , n O C       -> b -> c)-      -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)-fbnf3 (ff, fm, fl) block = unFF3 $ scottFoldBlock (ScottBlock f m l cat) block-    where f n = FF3 $ ff n-          m n = FF3 $ fm n-          l n = FF3 $ fl n-          -- XXX Ew.-          cat :: forall t t1 t2 t3 t4 t5 t6 t7 t8 t9 a b c e x.-                 (IndexedCO x c b ~ IndexedCO t9 t7 t6,-                  IndexedCO t8 t5 t6 ~ IndexedCO t4 t2 t1,-                  IndexedCO t3 t t1 ~ IndexedCO e a b) =>-                 FF3 t t1 t2 t3 t4 -> FF3 t5 t6 t7 t8 t9 -> FF3 a b c e x-          FF3 f `cat` FF3 f' = FF3 $ f' . f--newtype FF3 a b c e x = FF3 { unFF3 :: IndexedCO e a b -> IndexedCO x c b }--blockToNodeList'' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))-blockToNodeList'' = finish . unList . scottFoldBlock (ScottBlock f m l cat)-    where f n = NL (JustC n, id, NothingC)-          m n = NL (NothingC, (n:), NothingC)-          l n = NL (NothingC, id, JustC n)-          cat :: forall n t1 t3. NodeList n t1 O -> NodeList n O t3 -> NodeList n t1 t3-          NL (e, ms, NothingC) `cat` NL (NothingC, ms', x) = NL (e, ms . ms', x)-          finish :: forall t t1 t2 a. (t, [a] -> t1, t2) -> (t, t1, t2)-          finish (e, ms, x) = (e, ms [], x)----blockToNodeList' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))-blockToNodeList' b = unFNL $ foldBlockNodesF3''' ff fm fl b ()-  where ff :: forall n e. MaybeC e (n C O) -> () -> PNL n e-        fm :: forall n e. n O O -> PNL n e -> PNL n e-        fl :: forall n e x. MaybeC x (n O C) -> PNL n e -> FNL n e x-        ff n () = PNL (n, [])-        fm n (PNL (first, mids')) = PNL (first, n : mids')-        fl n (PNL (first, mids')) = FNL (first, reverse mids', n)--   -- newtypes for 'partial node list' and 'final node list'-newtype PNL n e   = PNL (MaybeC e (n C O), [n O O])-newtype FNL n e x = FNL {unFNL :: (MaybeC e (n C O), [n O O], MaybeC x (n O C))}--foldBlockNodesF3''' :: forall n a b c .-                       (forall e   . MaybeC e (n C O) -> a   -> b e)-                    -> (forall e   .           n O O  -> b e -> b e)-                    -> (forall e x . MaybeC x (n O C) -> b e -> c e x)-                    -> (forall e x . Block n e x      -> a   -> c e x)-foldBlockNodesF3''' ff fm fl = block-  where block   :: forall e x . Block n e x -> a   -> c e x-        blockCO ::              Block n C O -> a   -> b C-        blockOO :: forall e .   Block n O O -> b e -> b e-        blockOC :: forall e .   Block n O C -> b e -> c e C-        block (b1 `BClosed` b2) = blockCO b1       `cat` blockOC b2-        block (BFirst  node)    = ff (JustC node)  `cat` fl NothingC-        block (b @ BHead {})    = blockCO b        `cat` fl NothingC-        block (BMiddle node)    = ff NothingC `cat` fm node   `cat` fl NothingC-        block (b @ BCat {})     = ff NothingC `cat` blockOO b `cat` fl NothingC-        block (BLast   node)    = ff NothingC `cat` fl (JustC node)-        block (b @ BTail {})    = ff NothingC `cat` blockOC b-        blockCO (BFirst n)      = ff (JustC n)-        blockCO (BHead b n)     = blockCO b `cat` fm n-        blockOO (BMiddle n)     = fm n-        blockOO (BCat b1 b2)    = blockOO b1 `cat` blockOO b2-        blockOC (BLast n)       = fl (JustC n)-        blockOC (BTail n b)     = fm n `cat` blockOC b-        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c-        f `cat` g = g . f ----- | The following function is easy enough to define but maybe not so useful-foldBlockNodesF3' :: forall n a b c .-                   ( n C O -> a -> b-                   , n O O -> b -> b-                   , n O C -> b -> c)-                   -> (a -> b) -- called iff there is no first node-                   -> (b -> c) -- called iff there is no last node-                   -> (forall e x . Block n e x -> a -> c)-foldBlockNodesF3' (ff, fm, fl) missingFirst missingLast = block-  where block   :: forall e x . Block n e x -> a -> c-        blockCO ::              Block n C O -> a -> b-        blockOO ::              Block n O O -> b -> b-        blockOC ::              Block n O C -> b -> c-        block (b1 `BClosed` b2) = blockCO b1 `cat` blockOC b2-        block (BFirst  node)    = ff node  `cat` missingLast-        block (b @ BHead {})    = blockCO b `cat` missingLast-        block (BMiddle node)    = missingFirst `cat` fm node  `cat` missingLast-        block (b @ BCat {})     = missingFirst `cat` blockOO b `cat` missingLast-        block (BLast   node)    = missingFirst `cat` fl node-        block (b @ BTail {})    = missingFirst `cat` blockOC b-        blockCO (BFirst n)   = ff n-        blockCO (BHead b n)  = blockCO b `cat` fm n-        blockOO (BMiddle n)  = fm n-        blockOO (BCat b1 b2) = blockOO b1 `cat` blockOO b2-        blockOC (BLast n)    = fl n-        blockOC (BTail n b)  = fm n `cat` blockOC b-        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c-        f `cat` g = g . f ---- | Fold a function over every node in a block, forward or backward.--- The fold function must be polymorphic in the shape of the nodes.-foldBlockNodesF3 :: forall n a b c .-                   ( n C O       -> a -> b-                   , n O O       -> b -> b-                   , n O C       -> b -> c)-                 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)-foldBlockNodesF  :: forall n a .-                    (forall e x . n e x       -> a -> a)-                 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)-foldBlockNodesB3 :: forall n a b c .-                   ( n C O       -> b -> c-                   , n O O       -> b -> b-                   , n O C       -> a -> b)-                 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)-foldBlockNodesB  :: forall n a .-                    (forall e x . n e x       -> a -> a)-                 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)--- | Fold a function over every node in a graph.--- The fold function must be polymorphic in the shape of the nodes.--foldGraphNodes :: forall n a .-                  (forall e x . n e x       -> a -> a)-               -> (forall e x . Graph n e x -> a -> a)---foldBlockNodesF3 (ff, fm, fl) = block-  where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b-        block (BFirst  node)    = ff node-        block (BMiddle node)    = fm node-        block (BLast   node)    = fl node-        block (b1 `BCat`    b2) = block b1 `cat` block b2-        block (b1 `BClosed` b2) = block b1 `cat` block b2-        block (b1 `BHead` n)    = block b1 `cat` fm n-        block (n `BTail` b2)    = fm n `cat` block b2-        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c-        cat f f' = f' . f-foldBlockNodesF f = foldBlockNodesF3 (f, f, f)--foldBlockNodesB3 (ff, fm, fl) = block-  where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b-        block (BFirst  node)    = ff node-        block (BMiddle node)    = fm node-        block (BLast   node)    = fl node-        block (b1 `BCat`    b2) = block b1 `cat` block b2-        block (b1 `BClosed` b2) = block b1 `cat` block b2-        block (b1 `BHead` n)    = block b1 `cat` fm n-        block (n `BTail` b2)    = fm n `cat` block b2-        cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c-        cat f f' = f . f'-foldBlockNodesB f = foldBlockNodesB3 (f, f, f)---foldGraphNodes f = graph-    where graph :: forall e x . Graph n e x -> a -> a-          lift  :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a)--          graph GNil              = id-          graph (GUnit b)         = block b-          graph (GMany e b x)     = lift block e . body b . lift block x-          body :: Body n -> a -> a-          body bdy                = \a -> mapFold block a bdy-          lift _ NothingO         = id-          lift f (JustO thing)    = f thing--          block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a-          block = foldBlockNodesF f--{-# DEPRECATED blockToNodeList, blockOfNodeList -  "What justifies these functions?  Can they be eliminated?  Replaced with folds?" #-}------ | Convert a block to a list of nodes. The entry and exit node--- is or is not present depending on the shape of the block.------ The blockToNodeList function cannot be currently expressed using--- foldBlockNodesB, because it returns IndexedCO e a b, which means--- two different types depending on the shape of the block entry.--- But blockToNodeList returns one of four possible types, depending--- on the shape of the block entry *and* exit.-blockToNodeList :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))-blockToNodeList block = case block of-  BFirst n    -> (JustC n, [], NothingC)-  BMiddle n   -> (NothingC, [n], NothingC)-  BLast n     -> (NothingC, [], JustC n)-  BCat {}     -> (NothingC, foldOO block [], NothingC)-  BHead x n   -> case foldCO x [n] of (f, m) -> (f, m, NothingC)-  BTail n x   -> case foldOC x of (m, l) -> (NothingC, n : m, l)-  BClosed x y -> case foldOC y of (m, l) -> case foldCO x m of (f, m') -> (f, m', l)-  where foldCO :: Block n C O -> [n O O] -> (MaybeC C (n C O), [n O O])-        foldCO (BFirst n) m  = (JustC n, m)-        foldCO (BHead x n) m = foldCO x (n : m)--        foldOO :: Block n O O -> [n O O] -> [n O O]-        foldOO (BMiddle n) acc = n : acc-        foldOO (BCat x y) acc  = foldOO x $ foldOO y acc--        foldOC :: Block n O C -> ([n O O], MaybeC C (n O C))-        foldOC (BLast n)   = ([], JustC n)-        foldOC (BTail n x) = case foldOC x of (m, l) -> (n : m, l)---- | Convert a list of nodes to a block. The entry and exit node--- must or must not be present depending on the shape of the block.-blockOfNodeList :: (MaybeC e (n C O), [n O O], MaybeC x (n O C)) -> Block n e x-blockOfNodeList (NothingC, [], NothingC) = error "No nodes to created block from in blockOfNodeList"-blockOfNodeList (NothingC, m, NothingC)  = foldr1 BCat (map BMiddle m)-blockOfNodeList (NothingC, m, JustC l)   = foldr BTail (BLast l) m-blockOfNodeList (JustC f, m, NothingC)   = foldl BHead (BFirst f) m-blockOfNodeList (JustC f, m, JustC l)    = BClosed (BFirst f) $ foldr BTail (BLast l) m--data BlockResult n x where-  NoBlock   :: BlockResult n x-  BodyBlock :: Block n C C -> BlockResult n x-  ExitBlock :: Block n C O -> BlockResult n O--lookupBlock :: NonLocal n => Graph n e x -> Label -> BlockResult n x-lookupBlock (GMany _ _ (JustO exit)) lbl-  | entryLabel exit == lbl = ExitBlock exit-lookupBlock (GMany _ body _) lbl =-  case mapLookup lbl body of-    Just b  -> BodyBlock b-    Nothing -> NoBlock-lookupBlock GNil      _ = NoBlock-lookupBlock (GUnit _) _ = NoBlock