[commit: hoopl] simonmar-hoopl-opt: add blockCons, blockSnoc, and a bit of refactoring (9ec957d)

[Simon Marlow]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/hoopl

On branch  : simonmar-hoopl-opt

http://hackage.haskell.org/trac/ghc/changeset/9ec957d2e8b3e6508c68a63612d4c853a04c1087

>---------------------------------------------------------------

commit 9ec957d2e8b3e6508c68a63612d4c853a04c1087
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Thu Jan 26 16:01:49 2012 +0000

    add blockCons, blockSnoc, and a bit of refactoring

>---------------------------------------------------------------

 src/Compiler/Hoopl/XUtil.hs |   78 ++++++++++++++++++++++++++++++-------------
 1 files changed, 55 insertions(+), 23 deletions(-)

diff --git a/src/Compiler/Hoopl/XUtil.hs b/src/Compiler/Hoopl/XUtil.hs
index 2f06aba..ff5b59e 100644
--- a/src/Compiler/Hoopl/XUtil.hs
+++ b/src/Compiler/Hoopl/XUtil.hs
@@ -11,6 +11,7 @@ module Compiler.Hoopl.XUtil
 
     -- ** Simple operations on blocks
     isEmptyBlock
+  , emptyBlock, blockCons, blockSnoc
   , firstNode, lastNode, endNodes
   , blockSplitHead, blockSplitTail, blockSplit
   , blockJoinHead, blockJoinTail, blockJoin
@@ -57,12 +58,55 @@ import Compiler.Hoopl.Util
 -- -----------------------------------------------------------------------------
 -- 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
@@ -74,7 +118,6 @@ 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)
@@ -86,19 +129,20 @@ blockSplitTail (BlockCC f b t) = (BlockCO f b, t)
 blockSplit :: Block n C C -> (n C O, Block n O O, n O C)
 blockSplit (BlockCC f b t) = (f, b, t)
 
-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
+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
 
-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
+blockFromList :: [n O O] -> Block n O O
+blockFromList = foldr BTail BNil
 
-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
+-- Modifying
 
 replaceFirstNode :: Block n C x -> n C O -> Block n C x
 replaceFirstNode (BlockCO _ b)   f = BlockCO f b
@@ -109,18 +153,6 @@ replaceLastNode (BlockOC   b _) n = BlockOC b n
 replaceLastNode (BlockCC l b _) n = BlockCC l b n
 
 
-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
-
 -----------------------------------------------------------------------------
 
 {-