Change the block representation (version bumped to 3.9.0.0)
authorSimon Marlow <marlowsd@gmail.com>
Wed, 4 Jul 2012 15:57:45 +0000 (16:57 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Wed, 4 Jul 2012 15:57:45 +0000 (16:57 +0100)
This patch implements the change to the block representation as agreed
with Norman.  I also took the liberty of doing a lot of refactoring
and rearrangement to make the code organisation more logical.  A
summary of the API changes is below.

Summary of refactorings:

 - Compiler.Hoopl.Block contains the Block datatype and all the
   operations on Blocks.  It seemed like a good idea to collect all
   this stuff together in one place.

 - Compiler.Hoopl.Graph now has the operations on Graphs.

 - Compiler.Hoopl.Util and Compiler.Hoopl.GraphUtil are no more; their
   contents have been moved to other homes.  (and a bit of duplicated
   functionality has been removed).

 - I removed the newtypes around Unique and Label, these are now just
   type synonyms.  The newtype wrappers were costing some performance in
   GHC, because in cases like mapToList the newtype isn't optimised away.

   This change might be controversial.  Feel free to complain.

Other changes:

 - Optimisations to the Dataflow algorithms.  I'm not actually using
   this implementation of Dataflow in GHC any more, instead I have a
   local copy specialised to our monad, for speed.  Nevertheless I've
   put some of the optimisations I'm using in the GHC version into the
   generic library version too.

Summary of API changes:

ADDED

 - IsMap(mapInsertWith, mapFromListWith)

 - mapGraphBlocks
   (was previously called graphMapBlocks, and not exported)

 - mapBlock'
   (strict version of mapBlock)

 - New API for working with Blocks:

    -- ** 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

REMOVED

 - mapMaybeO, mapMaybeC
   (no need: we have Functor instances)

 - Block constructors are no longer exported
   (use the block API instead)

 - blockToNodeList, blockToNodeList', blockToNodeList'', blockToNodeList'''
   (use the block API instead)

 - tfFoldBlock, ScottBlock, scottFoldBlock, fbnf3,
   BlockResult(..), lookupBlock,
   (I don't know what any of these are for, if they're still important
   we could reinstate)

CHANGED

 - Compiler.Hoopl.GHC is now Compiler.Hoopl.Internals and exports some
   more stuff.

 - Label is not a newtype; type Label = Unique
 - Unique is not a newtype: type Unique = Int
   (these newtypes were adding overhead)

 - blockMapNodes3 is now mapBlock3'

 - Lots of internal refactoring and tidying up

25 files changed:
FAQ [deleted file]
LICENSE
hoopl.cabal
src/Compiler/Hoopl.hs
src/Compiler/Hoopl/Block.hs [new file with mode: 0644]
src/Compiler/Hoopl/Collections.hs
src/Compiler/Hoopl/Combinators.hs
src/Compiler/Hoopl/Dataflow.hs
src/Compiler/Hoopl/DataflowFold.hs
src/Compiler/Hoopl/Graph.hs
src/Compiler/Hoopl/GraphUtil.hs [deleted file]
src/Compiler/Hoopl/Internals.hs [new file with mode: 0644]
src/Compiler/Hoopl/Label.hs
src/Compiler/Hoopl/MkGraph.hs
src/Compiler/Hoopl/OldDataflow.hs
src/Compiler/Hoopl/Pointed.hs
src/Compiler/Hoopl/Show.hs
src/Compiler/Hoopl/Unique.hs
src/Compiler/Hoopl/Util.hs [deleted file]
src/Compiler/Hoopl/XUtil.hs
src/README [deleted file]
testing/EvalMonad.hs
testing/Main.hs
testing/Test.hs
testing/tests/ExpectedOutput

diff --git a/FAQ b/FAQ
deleted file mode 100644 (file)
index db8af30..0000000
--- a/FAQ
+++ /dev/null
@@ -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.
-
-
diff --git a/LICENSE b/LICENSE
index a9aa5c9..c5845d7 100644 (file)
--- a/LICENSE
+++ b/LICENSE
@@ -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
index dfb46ed..df18773 100644 (file)
@@ -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 @@ Library
   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 @@ Library
                      Compiler.Hoopl.Shape,
                      Compiler.Hoopl.Show, 
                      Compiler.Hoopl.Unique, 
-                     Compiler.Hoopl.Util,
                      Compiler.Hoopl.XUtil
 
   Ghc-Options:       -Wall -fno-warn-name-shadowing
index 37fa2f9..b1a435b 100644 (file)
@@ -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
   , 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.Combinators
 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
diff --git a/src/Compiler/Hoopl/Block.hs b/src/Compiler/Hoopl/Block.hs
new file mode 100644 (file)
index 0000000..9916b2e
--- /dev/null
@@ -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
+  BHead   :: Block n O O -> n O O       -> Block n O O
+  BTail   :: 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 `BTail` b) l
+  BNil{}    -> n `BTail` b
+  BMiddle{} -> n `BTail` b
+  BCat{}    -> n `BTail` b
+  BHead{}   -> n `BTail` b
+  BTail{}   -> n `BTail` 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 `BHead` n)
+  BNil{}      -> b `BHead` n
+  BMiddle{}   -> b `BHead` n
+  BCat{}      -> b `BHead` n
+  BHead{}     -> b `BHead` n
+  BTail{}     -> b `BHead` 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@BTail{}     -> (NothingC, b, NothingC)
+  b@BHead{}     -> (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 (BHead b1 n) r = go b1 (n:r)
+         go (BTail n b1) r = n : go b1 r
+
+blockFromList :: [n O O] -> Block n O O
+blockFromList = foldr BTail 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)
+                   BHead{}      -> BlockCO l $! (b1 `cat` y)
+                   BTail{}      -> BlockCO l $! (b1 `cat` y)
+
+  BMiddle n -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle{}     -> BTail n y
+                   BCat{}        -> BTail n y
+                   BHead{}       -> BTail n y
+                   BTail{}       -> BTail n y
+
+  BCat{} -> case y of
+                   BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2
+                   BNil          -> x
+                   BMiddle n     -> BHead x n
+                   BCat{}        -> BCat x y
+                   BHead{}       -> BCat x y
+                   BTail{}       -> BCat x y
+
+  BHead{} -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle n     -> BHead x n
+                   BCat{}        -> BCat x y
+                   BHead{}       -> BCat x y
+                   BTail{}       -> BCat x y
+
+
+  BTail{} -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle n     -> BHead x n
+                   BCat{}        -> BCat x y
+                   BHead{}       -> BCat x y
+                   BTail{}       -> 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 (BHead b n)     = BHead   (mapBlock f b)  (f n)
+mapBlock f (BTail n b)     = BTail   (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 (BHead x n)     = (BHead $! go x) $! (m n)
+        go (BTail n x)     = (BTail $! 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 `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 (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 `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)
+
+
+----------------------------------------------------------------
+
+-- | 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@BHead{}     -> fb b BNil
+   b@BTail{}     -> 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 = BTail n rest
+   fb (BCat l r)  rest = fb l (fb r rest)
+   fb (BTail n b) rest = BTail n (fb b rest)
+   fb (BHead b n) rest = fb b (BTail 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@BHead{}     -> bb BNil b
+   b@BTail{}     -> 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) = BHead rest n
+   bb rest (BCat l r) = bb (bb rest l) r
+   bb rest (BTail n b) = bb (BHead rest n) b
+   bb rest (BHead b n) = BHead (bb rest b) n
index 45e42c3..e7b1755 100644 (file)
@@ -59,6 +59,7 @@ class IsMap map where
   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 @@ class IsMap map where
   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
index 5c71d19..919c9cc 100644 (file)
@@ -19,7 +19,8 @@ import Data.Maybe
 import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Dataflow
 import Compiler.Hoopl.Fuel
-import Compiler.Hoopl.Graph (Graph, C, O, Shape(..))
+import Compiler.Hoopl.Block
+import Compiler.Hoopl.Graph (Graph)
 import Compiler.Hoopl.Label
 
 ----------------------------------------------------------------
index 3053cc3..43af694 100644 (file)
@@ -1,35 +1,44 @@
 {-# 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
 
 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 +102,7 @@ newtype FwdRewrite m n f   -- see Note [Respects Fuel]
                     , 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 +111,9 @@ wrapFR :: (forall e x. (n  e x -> f  -> m  (Maybe (Graph n  e x, FwdRewrite m  n
        -> 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 +198,9 @@ type Entries e = MaybeC e [Label]
 arfGraph :: forall m n f e x .
             (NonLocal n, CheckpointMonad m) => FwdPass m n f -> 
             Entries e -> Graph n e x -> Fact e f -> m (DG f n e x, Fact x f)
-arfGraph pass entries = graph
+arfGraph pass@FwdPass { fp_lattice = lattice,
+                        fp_transfer = transfer @ (FwdTransfer3 (ftr, mtr, ltr)),
+                        fp_rewrite  = rewrite @ (FwdRewrite3 (frw, mrw, lrw)) } 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 +246,23 @@ arfGraph pass entries = graph
 
     -- 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
 
 -- @ 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 +284,6 @@ arfGraph pass entries = graph
          -> (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 +292,10 @@ arfGraph pass entries = graph
                     -- the Body are in the 'DG f n C C'
 -- @ start bodyfun.tex
     body entries blockmap init_fbase
-      = fixpoint Fwd lattice do_block blocks init_fbase
+      = fixpoint Fwd lattice do_block 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 +337,7 @@ newtype BwdRewrite m n f
                     , 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 +350,7 @@ wrapBR :: (forall e x .
 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 +403,9 @@ mkBRewrite f = mkBRewrite3 f f f
 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 +437,25 @@ arbGraph pass entries = graph
              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
 
     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 +470,7 @@ arbGraph pass entries = graph
          -> (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 +479,14 @@ arbGraph pass entries = graph
                     -- in the Body; the facts for Labels *in*
                     -- the Body are in the 'DG f n C C'
     body entries blockmap init_fbase
-      = fixpoint Bwd (bp_lattice pass) do_block blocks init_fbase
+      = fixpoint Bwd 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 +530,18 @@ distinguishedEntryFact g f = maybe g
 -----------------------------------------------------------------------------
 --      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 +551,6 @@ updateFact lat lbls lbl new_fact (cha, fbase)
                  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,73 +565,61 @@ fixpoint :: forall m n f. (CheckpointMonad m, NonLocal n)
  => Direction
  -> DataflowLattice f
  -> (Block n C C -> Fact C f -> m (DG f n C C, Fact C f))
- -> [Block n C C]
+ -> [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]
-
-    tx_blocks :: [((Label, Block n C C), [Label])]   -- I do not understand this type
-              -> TxFactBase n f -> m (TxFactBase n f)
-    tx_blocks []              tx_fb = return tx_fb
-    tx_blocks (((lbl,blk), in_lbls):bs) tx_fb 
-      = tx_block lbl blk in_lbls tx_fb >>= tx_blocks bs
-     -- "in_lbls" == Labels the block may 
-     --                 _depend_ upon for facts
-
-    tx_block :: Label -> Block n C C -> [Label]
-             -> TxFactBase n f -> m (TxFactBase n f)
-    tx_block lbl blk in_lbls 
-        tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls
-                    , tfb_rg = blks, tfb_cha = cha })
-      | is_fwd && not (lbl `mapMember` fbase)
-      = return (tx_fb {tfb_lbls = lbls'})       -- Note [Unreachable blocks]
-      | otherwise
-      = do { (rg, out_facts) <- do_block blk fbase
-           ; let (cha', fbase') = mapFoldWithKey
-                                  (updateFact lat lbls')
-                                  (cha,fbase) out_facts
-           ; return $
-               TxFB { tfb_lbls  = lbls'
-                    , tfb_rg    = rg `dgSplice` blks
-                    , tfb_fbase = fbase'
-                    , tfb_cha = cha' } }
-      where
-        lbls' = lbls `setUnion` setFromList in_lbls
-        
-
-    loop :: FactBase f -> m (TxFactBase n f)
-    loop fbase 
-      = do { s <- checkpoint
-           ; let init_tx :: TxFactBase n f
-                 init_tx = TxFB { tfb_fbase = fbase
-                                , tfb_cha   = NoChange
-                                , tfb_rg    = dgnilC
-                                , tfb_lbls  = setEmpty }
-           ; tx_fb <- tx_blocks tagged_blocks init_tx
-           ; case tfb_cha tx_fb of
-               NoChange   -> return tx_fb
-               SomeChange 
-                 -> do { restart s
-                       ; loop (tfb_fbase tx_fb) } }
--- @ end fpimp.tex           
+    -- 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
+                        ]
+
+    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))
+
+    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
+
+           -- 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]
@@ -712,14 +713,13 @@ dgSplice  :: NonLocal n => DG f n e a -> DG f n a x -> DG f n e x
 
 ---- observers
 
-type GraphWithFacts n f e x = (Graph n e x, FactBase f)
-  -- A Graph together with the facts for that graph
-  -- The domains of the two maps should be identical
-
 normalizeGraph :: forall n f e x .
-                  NonLocal n => DG f n e x -> GraphWithFacts n f e x
+                  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 +730,18 @@ normalizeGraph g = (graphMapBlocks dropFact g, facts g)
           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 b) 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 +758,43 @@ class ShapeLifter e x where
  singletonDG   :: f -> n e x -> DG f n e x
  fwdEntryFact  :: NonLocal n => n e x -> f -> Fact e f
  fwdEntryLabel :: NonLocal n => n e x -> MaybeC e [Label]
- ftransfer :: FwdPass m n f -> n e x -> f -> Fact x f
- frewrite  :: FwdPass m n f -> n e x 
+ 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
index 1c4b091..74cd8eb 100644 (file)
@@ -73,7 +73,6 @@ import Data.Maybe
 import Compiler.Hoopl.Fuel
 import Compiler.Hoopl.Graph
 import Compiler.Hoopl.MkGraph
-import qualified Compiler.Hoopl.GraphUtil as U
 import Compiler.Hoopl.Label
 import Compiler.Hoopl.Util
 
@@ -620,8 +619,8 @@ normalizeGraph g = (graphMapBlocks dropFact g, facts g)
           exitFacts :: MaybeO x (FBlock f n C O) -> FactBase f
           exitFacts NothingO = noFacts
           exitFacts (JustO (FBlock f b)) = mkFactBase [(entryLabel b, f)]
-          bodyFacts :: Body' (FBlock f) n -> FactBase f
-          bodyFacts (Body body) = foldLabelMap f noFacts body
+          bodyFacts :: Body (FBlock f) n -> FactBase f
+          bodyFacts body = foldLabelMap f noFacts body
             where f (FBlock f b) fb = extendFactBase fb (entryLabel b) f
 
 --- implementation of the constructors (boring)
index 27c00ea..d9dda80 100644 (file)
@@ -1,97 +1,98 @@
-{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies, Rank2Types #-}
+{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies, ScopedTypeVariables,
+    RankNTypes, FlexibleInstances #-}
 #if __GLASGOW_HASKELL__ >= 701
 {-# LANGUAGE Safe #-}
 #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
------------------------------------------------------------------------------
-
--- | 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
+import Control.Monad
+
+
+-- -----------------------------------------------------------------------------
+-- 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
@@ -101,49 +102,310 @@ class NonLocal thing where
   successors :: thing e C -> [Label] -- ^ Gives control-flow successors
 
 instance NonLocal n => NonLocal (Block n) where
-  entryLabel (BFirst n)    = entryLabel n
-  entryLabel (BHead h _)   = entryLabel h
-  entryLabel (BClosed h _) = entryLabel h
-  successors (BLast n)     = successors n
-  successors (BTail _ t)   = successors t
-  successors (BClosed _ t) = successors t
-
-------------------------------
-emptyBody :: LabelMap (thing C C)
-emptyBody = mapEmpty
+  entryLabel (BlockCO f _)   = entryLabel f
+  entryLabel (BlockCC f _ _) = entryLabel f
 
-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
+  successors (BlockOC   _ n) = successors n
+  successors (BlockCC _ _ n) = successors n
 
-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 $ BHead b n
+catGraphNodeOO (GMany e body (JustO (BlockCO f b))) n
+  = GMany e body (JustO (BlockCO f (BHead 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 $ BTail n b
+catNodeOOGraph n (GMany (JustO (BlockOC b l)) body x)
+   = GMany (JustO (BlockOC (n `BTail` 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@(BHead {})   = gUnitOO b
+blockGraph b@(BTail {})   = 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)
-
-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)
-
-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)
-
-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)
+mapGraph f = mapGraphBlocks (mapBlock f)
+
+-- | 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)
+
+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)
+
+
+-- -----------------------------------------------------------------------------
+-- 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
+
diff --git a/src/Compiler/Hoopl/GraphUtil.hs b/src/Compiler/Hoopl/GraphUtil.hs
deleted file mode 100644 (file)
index 06904ef..0000000
+++ /dev/null
@@ -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
diff --git a/src/Compiler/Hoopl/Internals.hs b/src/Compiler/Hoopl/Internals.hs
new file mode 100644 (file)
index 0000000..aa7a3c9
--- /dev/null
@@ -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
index a8d40ea..e8a60ef 100644 (file)
@@ -22,79 +22,22 @@ import Compiler.Hoopl.Unique
 --             Label
 -----------------------------------------------------------------------------
 
-newtype Label = Label { lblToUnique :: Unique }
-  deriving (Eq, Ord)
+type Label = Unique
+
+lblToUnique :: Label -> Unique
+lblToUnique = id
 
 uniqueToLbl :: Unique -> Label
-uniqueToLbl = Label
+uniqueToLbl = id
 
-instance Show Label where
-  show (Label n) = "L" ++ show n
+--instance Show Label where
+--  show (Label n) = "L" ++ show n
 
 freshLabel :: UniqueMonad m => m Label
 freshLabel = freshUnique >>= return . uniqueToLbl
 
------------------------------------------------------------------------------
--- LabelSet
-
-newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show)
-
-instance IsSet LabelSet where
-  type ElemOf LabelSet = Label
-
-  setNull (LS s) = setNull s
-  setSize (LS s) = setSize s
-  setMember (Label k) (LS s) = setMember k s
-
-  setEmpty = LS setEmpty
-  setSingleton (Label k) = LS (setSingleton k)
-  setInsert (Label k) (LS s) = LS (setInsert k s)
-  setDelete (Label k) (LS s) = LS (setDelete k s)
-
-  setUnion (LS x) (LS y) = LS (setUnion x y)
-  setDifference (LS x) (LS y) = LS (setDifference x y)
-  setIntersection (LS x) (LS y) = LS (setIntersection x y)
-  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
-
-  setFold k z (LS s) = setFold (k . uniqueToLbl) z s
-
-  setElems (LS s) = map uniqueToLbl (setElems s)
-  setFromList ks = LS (setFromList (map lblToUnique ks))
-
------------------------------------------------------------------------------
--- LabelMap
-
-newtype LabelMap v = LM (UniqueMap v) deriving (Eq, Ord, Show)
-
-instance IsMap LabelMap where
-  type KeyOf LabelMap = Label
-
-  mapNull (LM m) = mapNull m
-  mapSize (LM m) = mapSize m
-  mapMember (Label k) (LM m) = mapMember k m
-  mapLookup (Label k) (LM m) = mapLookup k m
-  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m
-
-  mapEmpty = LM mapEmpty
-  mapSingleton (Label k) v = LM (mapSingleton k v)
-  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
-  mapDelete (Label k) (LM m) = LM (mapDelete k m)
-
-  mapUnion (LM x) (LM y) = LM (mapUnion x y)
-  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y)
-  mapDifference (LM x) (LM y) = LM (mapDifference x y)
-  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
-  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y
-
-  mapMap f (LM m) = LM (mapMap f m)
-  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m)
-  mapFold k z (LM m) = mapFold k z m
-  mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m
-
-  mapElems (LM m) = mapElems m
-  mapKeys (LM m) = map uniqueToLbl (mapKeys m)
-  mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m]
-  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
+type LabelSet = UniqueSet
+type LabelMap v = UniqueMap v
 
 -----------------------------------------------------------------------------
 -- FactBase
index 6efbd83..769b28b 100644 (file)
@@ -14,9 +14,9 @@ module Compiler.Hoopl.MkGraph
     )
 where
 
-import Compiler.Hoopl.Label (Label, uniqueToLbl)
-import Compiler.Hoopl.Graph
-import qualified Compiler.Hoopl.GraphUtil as U
+import Compiler.Hoopl.Label (Label)
+import Compiler.Hoopl.Block
+import Compiler.Hoopl.Graph as U
 import Compiler.Hoopl.Unique
 import Control.Monad (liftM2)
 
@@ -70,8 +70,8 @@ class GraphRep g where
   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.
@@ -147,8 +147,8 @@ class Uniques u where
 instance Uniques Unique where
   withFresh f = A $ freshUnique >>= (graphOfAGraph . f)
 
-instance Uniques Label where
-  withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl)
+--instance Uniques Label where
+--  withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl)
 
 -- | Lifts binary 'Graph' functions into 'AGraph' functions.
 liftA2 :: (Graph  n a b -> Graph  n c d -> Graph  n e f)
index 2177431..b258782 100644 (file)
@@ -75,7 +75,6 @@ import Data.Maybe
 import Compiler.Hoopl.Fuel
 import Compiler.Hoopl.Graph
 import Compiler.Hoopl.MkGraph
-import qualified Compiler.Hoopl.GraphUtil as U
 import Compiler.Hoopl.Label
 import Compiler.Hoopl.Util
 
index ea82861..df54b03 100644 (file)
@@ -12,7 +12,7 @@ module Compiler.Hoopl.Pointed
   )
 where
 
-import Compiler.Hoopl.Graph
+import Compiler.Hoopl.Block
 import Compiler.Hoopl.Label
 import Compiler.Hoopl.Dataflow
 
index 383727f..a0cd46a 100644 (file)
@@ -9,6 +9,7 @@ module Compiler.Hoopl.Show
 where
 
 import Compiler.Hoopl.Collections
+import Compiler.Hoopl.Block
 import Compiler.Hoopl.Graph
 import Compiler.Hoopl.Label
 
@@ -28,13 +29,14 @@ showGraph node = g
             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 (BTail n b1)    = node n ++ "\n" ++ b b1
 
 open :: (a -> String) -> MaybeO z a -> String
 open _ NothingO  = ""
index 6b4a570..b69cbee 100644 (file)
@@ -25,14 +25,13 @@ import qualified Data.IntSet as S
 --             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 @@ instance IsSet UniqueSet where
 
   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 @@ instance IsMap UniqueMap where
 
   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 @@ instance IsMap UniqueMap where
   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 :: Monad m => UniqueMonadT m a -> m a
 runUniqueMonadT m = do { (a, _) <- unUMT m allUniques; return a }
 
 allUniques :: [Unique]
-allUniques = map Unique [1..]
+allUniques = [1..]
diff --git a/src/Compiler/Hoopl/Util.hs b/src/Compiler/Hoopl/Util.hs
deleted file mode 100644 (file)
index 94dd8d1..0000000
+++ /dev/null
@@ -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
index 25e4866..709c37e 100644 (file)
@@ -6,38 +6,26 @@
 -- | Utilities for clients of Hoopl, not used internally.
 
 module Compiler.Hoopl.XUtil
-  ( firstXfer, distributeXfer
-  , distributeFact, distributeFactBwd
+  (
+    -- * Utilities for clients
+    distributeFact, distributeFactBwd
   , successorFacts
   , joinFacts
   , joinOutFacts -- deprecated
   , joinMaps
-  , foldGraphNodes
-  , foldBlockNodesF, foldBlockNodesB, foldBlockNodesF3, foldBlockNodesB3
-  , tfFoldBlock
-  , ScottBlock(ScottBlock), scottFoldBlock
-  , fbnf3
-  , blockToNodeList, blockOfNodeList
-  , blockToNodeList'   -- alternate version using fold
-  , blockToNodeList''  -- alternate version using scottFoldBlock
-  , blockToNodeList''' -- alternate version using tfFoldBlock
-  , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody
-  , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx
-  , noEntries
-  , BlockResult(..), lookupBlock
   )
 where
 
 import qualified Data.Map as M
 import Data.Maybe
 
-import Compiler.Hoopl.Checkpoint
 import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Dataflow
+import Compiler.Hoopl.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 +115,7 @@ distributeXfer :: NonLocal n
 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 +163,3 @@ joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldrWithKey add (NoChange, o
 
 
 
--- | 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
diff --git a/src/README b/src/README
deleted file mode 100644 (file)
index 741d7d9..0000000
+++ /dev/null
@@ -1,35 +0,0 @@
-This is Hoopl, a higher-order optimization library.
-There are two unpublished papers describing Hoopl:
-
-  Hoopl: Dataflow Optimization Made Simple
-  Hoopl: A Modular, Reusable Library for Dataflow Analysis and Transformation
-
-The second such paper is attached to this package.
-
-The version number is split into four parts:
-
-  3.   Third major body plan (phylum)
-  7.   Seventh iteration (roughly) of data structures
-  2.   Major version; changes when clients must change
-  1.   Minor version; changes when clients can stay the same
-
-
-Version 3.7.3.3 has fixed known bugs.
-
-Version 3.7.8.0 will be the last version uploaded to Hackage for some time.
-This library is undergoing *very* rapid development, and we ask that you
-get the most recent version from our public git repository:
-
-  git clone -o tufts git://ghc.cs.tufts.edu/hoopl/hoopl.git
-
-If you are not familiar with git, we recommend the tutorial 'Git Magic'
-by Ben Lynn.  To get some ideas about how to use git effectively,
-
-  http://whygitisbetterthanx.com/ 
-
-is also useful.
-
-If you've been given an account at Tufts with write privileges to the
-git repository, you'll want to use a different URL:
-
-  git clone -o tufts linux.cs.tufts.edu:/r/ghc/www/hoopl/hoopl.git
index c2f78cd..024d585 100644 (file)
@@ -131,7 +131,7 @@ mlookup blame k m =
     Nothing -> throwError ("unknown lookup for " ++ blame)
 
 blookup :: String -> G -> Label -> EvalM v B
-blookup blame g lbl = 
-  case lookupBlock g lbl of
-    BodyBlock b -> return b
-    NoBlock     -> throwError ("unknown lookup for " ++ blame)
+blookup blame (GMany _ blks _) lbl =
+  case mapLookup lbl blks of
+    Just b  -> return b
+    Nothing -> throwError ("unknown lookup for " ++ blame)
index 72a5b14..6db804b 100644 (file)
@@ -1,6 +1,7 @@
 module Main (main) where
 
 import Test
+import System.IO
 
 -- Hardcoding test locations for now
 tests = map (\t -> "tests" ++ "/" ++ t)
@@ -8,5 +9,7 @@ tests = map (\t -> "tests" ++ "/" ++ t)
              ["if-test", "if-test2", "if-test3", "if-test4"])
 
 main :: IO ()
-main = do mapM (\x -> putStrLn ("Test:" ++ x) >> parseTest x >> optTest x) tests
+main = do hSetBuffering stdout NoBuffering
+          hSetBuffering stderr NoBuffering
+          mapM (\x -> putStrLn ("Test:" ++ x) >> parseTest x >> optTest x) tests
           return ()
index ea443f3..8c34b1c 100644 (file)
@@ -12,6 +12,7 @@ import IR
 import Live
 import Parse (parseCode)
 import Simplify
+import Debug.Trace
 
 parse :: String -> String -> ErrorM (M [Proc])
 parse file text =
@@ -52,6 +53,7 @@ optTest' file text =
     optProc proc@(Proc {entry, body, args}) =
       do { (body',  _, _) <- analyzeAndRewriteFwd fwd (JustC [entry]) body
                              (mapSingleton entry (initFact args))
+         ; trace (showProc (proc {body=body'})) $ return ()
          ; (body'', _, _) <- analyzeAndRewriteBwd bwd (JustC [entry]) body' mapEmpty
          ; return $ proc { body = body'' } }
     -- With debugging info: 
index 6c8869f..9ee7ffc 100644 (file)
@@ -1,3 +1,4 @@
+Test:tests/test1
 f(a, b) {
 L1:
   r0 = 3
@@ -11,6 +12,7 @@ L1:
   ret (7)
 }
 
+Test:tests/test2
 f(a, b) {
 L1:
   x = 5
@@ -33,14 +35,15 @@ L1:
   goto L2
 L2:
   if x > 0 then goto L3 else goto L4
-L4:
-  ret (y)
 L3:
   y = y + x
   x = x - 1
   goto L2
+L4:
+  ret (y)
 }
 
+Test:tests/test3
 f(x, y) {
 L1:
   goto L2
@@ -48,12 +51,12 @@ L2:
   if x > 0 then goto L3 else goto L4
 L3:
   (z) = f(x - 1, y - 1) goto L5
+L4:
+  ret (y)
 L5:
   y = y + z
   x = x - 1
   goto L2
-L4:
-  ret (y)
 }
 
 f(x, y) {
@@ -61,16 +64,17 @@ L1:
   goto L2
 L2:
   if x > 0 then goto L3 else goto L4
-L4:
-  ret (y)
 L3:
   (z) = f(x - 1, y - 1) goto L5
+L4:
+  ret (y)
 L5:
   y = y + z
   x = x - 1
   goto L2
 }
 
+Test:tests/test4
 f(x) {
 L1:
   y = 5
@@ -93,6 +97,7 @@ L4:
   ret ((x + 5) + 4)
 }
 
+Test:tests/if-test
 f() {
 L1:
   x = 3 + 4
@@ -111,6 +116,7 @@ L2:
   ret (1)
 }
 
+Test:tests/if-test2
 f(a) {
 L1:
   x = 3 + 4
@@ -122,6 +128,8 @@ L3:
   a = a - 1
   res = res + x
   if x > 5 then goto L5 else goto L6
+L4:
+  ret (res)
 L5:
   goto L7
 L6:
@@ -129,8 +137,6 @@ L6:
   goto L7
 L7:
   goto L2
-L4:
-  ret (res)
 }
 
 f(a) {
@@ -139,18 +145,19 @@ L1:
   goto L2
 L2:
   if a > 0 then goto L3 else goto L4
-L4:
-  ret (res)
 L3:
   a = a - 1
   res = res + 7
   goto L5
+L4:
+  ret (res)
 L5:
   goto L7
 L7:
   goto L2
 }
 
+Test:tests/if-test3
 f(x) {
 L1:
   if x > 5 then goto L2 else goto L3
@@ -167,14 +174,15 @@ L4:
 f(x) {
 L1:
   if x > 5 then goto L2 else goto L3
-L3:
-  goto L4
 L2:
   goto L4
+L3:
+  goto L4
 L4:
   ret (1)
 }
 
+Test:tests/if-test4
 f(x) {
 L1:
   if x > 5 then goto L2 else goto L3
@@ -191,12 +199,12 @@ L4:
 f(x) {
 L1:
   if x > 5 then goto L2 else goto L3
-L3:
-  z = 2
-  goto L4
 L2:
   z = 1
   goto L4
+L3:
+  z = 2
+  goto L4
 L4:
   ret (z)
 }