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 <[email protected]> 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 - ----------------------------------------------------------------------------- {- _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
