never executed always true always false
    1 {-# LANGUAGE DataKinds #-}
    2 {-# LANGUAGE DeriveFunctor #-}
    3 {-# LANGUAGE GADTs #-}
    4 {-# LANGUAGE PolyKinds #-}
    5 {-# LANGUAGE RankNTypes #-}
    6 {-# LANGUAGE ScopedTypeVariables #-}
    7 {-# LANGUAGE StandaloneDeriving #-}
    8 {-# LANGUAGE TypeFamilies #-}
    9 module GHC.Cmm.Dataflow.Block
   10     ( Extensibility (..)
   11     , O
   12     , C
   13     , MaybeO(..)
   14     , IndexedCO
   15     , Block(..)
   16     , blockAppend
   17     , blockCons
   18     , blockFromList
   19     , blockJoin
   20     , blockJoinHead
   21     , blockJoinTail
   22     , blockSnoc
   23     , blockSplit
   24     , blockSplitHead
   25     , blockSplitTail
   26     , blockToList
   27     , emptyBlock
   28     , firstNode
   29     , foldBlockNodesB
   30     , foldBlockNodesB3
   31     , foldBlockNodesF
   32     , isEmptyBlock
   33     , lastNode
   34     , mapBlock
   35     , mapBlock'
   36     , mapBlock3'
   37     , replaceFirstNode
   38     , replaceLastNode
   39     ) where
   40 
   41 import GHC.Prelude
   42 
   43 -- -----------------------------------------------------------------------------
   44 -- Shapes: Open and Closed
   45 
   46 -- | Used at the type level to indicate "open" vs "closed" structure.
   47 data Extensibility
   48   -- | An "open" structure with a unique, unnamed control-flow edge flowing in
   49   -- or out. \"Fallthrough\" and concatenation are permitted at an open point.
   50   = Open
   51   -- | A "closed" structure which supports control transfer only through the use
   52   -- of named labels---no "fallthrough" is permitted. The number of control-flow
   53   -- edges is unconstrained.
   54   | Closed
   55 
   56 type O = 'Open
   57 type C = 'Closed
   58 
   59 -- | Either type indexed by closed/open using type families
   60 type family IndexedCO (ex :: Extensibility) (a :: k) (b :: k) :: k
   61 type instance IndexedCO C a _b = a
   62 type instance IndexedCO O _a b = b
   63 
   64 -- | Maybe type indexed by open/closed
   65 data MaybeO ex t where
   66   JustO    :: t -> MaybeO O t
   67   NothingO ::      MaybeO C t
   68 
   69 deriving instance Functor (MaybeO ex)
   70 
   71 -- -----------------------------------------------------------------------------
   72 -- The Block type
   73 
   74 -- | A sequence of nodes.  May be any of four shapes (O/O, O/C, C/O, C/C).
   75 -- Open at the entry means single entry, mutatis mutandis for exit.
   76 -- A closed/closed block is a /basic/ block and can't be extended further.
   77 -- Clients should avoid manipulating blocks and should stick to either nodes
   78 -- or graphs.
   79 data Block n e x where
   80   BlockCO  :: n C O -> Block n O O          -> Block n C O
   81   BlockCC  :: n C O -> Block n O O -> n O C -> Block n C C
   82   BlockOC  ::          Block n O O -> n O C -> Block n O C
   83 
   84   BNil    :: Block n O O
   85   BMiddle :: n O O                      -> Block n O O
   86   BCat    :: Block n O O -> Block n O O -> Block n O O
   87   BSnoc   :: Block n O O -> n O O       -> Block n O O
   88   BCons   :: n O O       -> Block n O O -> Block n O O
   89 
   90 
   91 -- -----------------------------------------------------------------------------
   92 -- Simple operations on Blocks
   93 
   94 -- Predicates
   95 
   96 isEmptyBlock :: Block n e x -> Bool
   97 isEmptyBlock BNil       = True
   98 isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r
   99 isEmptyBlock _          = False
  100 
  101 
  102 -- Building
  103 
  104 emptyBlock :: Block n O O
  105 emptyBlock = BNil
  106 
  107 blockCons :: n O O -> Block n O x -> Block n O x
  108 blockCons n b = case b of
  109   BlockOC b l  -> (BlockOC $! (n `blockCons` b)) l
  110   BNil{}    -> BMiddle n
  111   BMiddle{} -> n `BCons` b
  112   BCat{}    -> n `BCons` b
  113   BSnoc{}   -> n `BCons` b
  114   BCons{}   -> n `BCons` b
  115 
  116 blockSnoc :: Block n e O -> n O O -> Block n e O
  117 blockSnoc b n = case b of
  118   BlockCO f b -> BlockCO f $! (b `blockSnoc` n)
  119   BNil{}      -> BMiddle n
  120   BMiddle{}   -> b `BSnoc` n
  121   BCat{}      -> b `BSnoc` n
  122   BSnoc{}     -> b `BSnoc` n
  123   BCons{}     -> b `BSnoc` n
  124 
  125 blockJoinHead :: n C O -> Block n O x -> Block n C x
  126 blockJoinHead f (BlockOC b l) = BlockCC f b l
  127 blockJoinHead f b = BlockCO f BNil `cat` b
  128 
  129 blockJoinTail :: Block n e O -> n O C -> Block n e C
  130 blockJoinTail (BlockCO f b) t = BlockCC f b t
  131 blockJoinTail b t = b `cat` BlockOC BNil t
  132 
  133 blockJoin :: n C O -> Block n O O -> n O C -> Block n C C
  134 blockJoin f b t = BlockCC f b t
  135 
  136 blockAppend :: Block n e O -> Block n O x -> Block n e x
  137 blockAppend = cat
  138 
  139 
  140 -- Taking apart
  141 
  142 firstNode :: Block n C x -> n C O
  143 firstNode (BlockCO n _)   = n
  144 firstNode (BlockCC n _ _) = n
  145 
  146 lastNode :: Block n x C -> n O C
  147 lastNode (BlockOC   _ n) = n
  148 lastNode (BlockCC _ _ n) = n
  149 
  150 blockSplitHead :: Block n C x -> (n C O, Block n O x)
  151 blockSplitHead (BlockCO n b)   = (n, b)
  152 blockSplitHead (BlockCC n b t) = (n, BlockOC b t)
  153 
  154 blockSplitTail :: Block n e C -> (Block n e O, n O C)
  155 blockSplitTail (BlockOC b n)   = (b, n)
  156 blockSplitTail (BlockCC f b t) = (BlockCO f b, t)
  157 
  158 -- | Split a closed block into its entry node, open middle block, and
  159 -- exit node.
  160 blockSplit :: Block n C C -> (n C O, Block n O O, n O C)
  161 blockSplit (BlockCC f b t) = (f, b, t)
  162 
  163 blockToList :: Block n O O -> [n O O]
  164 blockToList b = go b []
  165    where go :: Block n O O -> [n O O] -> [n O O]
  166          go BNil         r = r
  167          go (BMiddle n)  r = n : r
  168          go (BCat b1 b2) r = go b1 $! go b2 r
  169          go (BSnoc b1 n) r = go b1 (n:r)
  170          go (BCons n b1) r = n : go b1 r
  171 
  172 blockFromList :: [n O O] -> Block n O O
  173 blockFromList = foldr BCons BNil
  174 
  175 -- Modifying
  176 
  177 replaceFirstNode :: Block n C x -> n C O -> Block n C x
  178 replaceFirstNode (BlockCO _ b)   f = BlockCO f b
  179 replaceFirstNode (BlockCC _ b n) f = BlockCC f b n
  180 
  181 replaceLastNode :: Block n x C -> n O C -> Block n x C
  182 replaceLastNode (BlockOC   b _) n = BlockOC b n
  183 replaceLastNode (BlockCC l b _) n = BlockCC l b n
  184 
  185 -- -----------------------------------------------------------------------------
  186 -- General concatenation
  187 
  188 cat :: Block n e O -> Block n O x -> Block n e x
  189 cat x y = case x of
  190   BNil -> y
  191 
  192   BlockCO l b1 -> case y of
  193                    BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n
  194                    BNil         -> x
  195                    BMiddle _    -> BlockCO l $! (b1 `cat` y)
  196                    BCat{}       -> BlockCO l $! (b1 `cat` y)
  197                    BSnoc{}      -> BlockCO l $! (b1 `cat` y)
  198                    BCons{}      -> BlockCO l $! (b1 `cat` y)
  199 
  200   BMiddle n -> case y of
  201                    BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
  202                    BNil          -> x
  203                    BMiddle{}     -> BCons n y
  204                    BCat{}        -> BCons n y
  205                    BSnoc{}       -> BCons n y
  206                    BCons{}       -> BCons n y
  207 
  208   BCat{} -> case y of
  209                    BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2
  210                    BNil          -> x
  211                    BMiddle n     -> BSnoc x n
  212                    BCat{}        -> BCat x y
  213                    BSnoc{}       -> BCat x y
  214                    BCons{}       -> BCat x y
  215 
  216   BSnoc{} -> case y of
  217                    BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
  218                    BNil          -> x
  219                    BMiddle n     -> BSnoc x n
  220                    BCat{}        -> BCat x y
  221                    BSnoc{}       -> BCat x y
  222                    BCons{}       -> BCat x y
  223 
  224 
  225   BCons{} -> case y of
  226                    BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
  227                    BNil          -> x
  228                    BMiddle n     -> BSnoc x n
  229                    BCat{}        -> BCat x y
  230                    BSnoc{}       -> BCat x y
  231                    BCons{}       -> BCat x y
  232 
  233 
  234 -- -----------------------------------------------------------------------------
  235 -- Mapping
  236 
  237 -- | map a function over the nodes of a 'Block'
  238 mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x
  239 mapBlock f (BlockCO n b  ) = BlockCO (f n) (mapBlock f b)
  240 mapBlock f (BlockOC   b n) = BlockOC       (mapBlock f b) (f n)
  241 mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m)
  242 mapBlock _  BNil           = BNil
  243 mapBlock f (BMiddle n)     = BMiddle (f n)
  244 mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)
  245 mapBlock f (BSnoc b n)     = BSnoc   (mapBlock f b)  (f n)
  246 mapBlock f (BCons n b)     = BCons   (f n)  (mapBlock f b)
  247 
  248 -- | A strict 'mapBlock'
  249 mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x)
  250 mapBlock' f = mapBlock3' (f, f, f)
  251 
  252 -- | map over a block, with different functions to apply to first nodes,
  253 -- middle nodes and last nodes respectively.  The map is strict.
  254 --
  255 mapBlock3' :: forall n n' e x .
  256              ( n C O -> n' C O
  257              , n O O -> n' O O,
  258                n O C -> n' O C)
  259           -> Block n e x -> Block n' e x
  260 mapBlock3' (f, m, l) b = go b
  261   where go :: forall e x . Block n e x -> Block n' e x
  262         go (BlockOC b y)   = (BlockOC $! go b) $! l y
  263         go (BlockCO x b)   = (BlockCO $! f x) $! (go b)
  264         go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y)
  265         go BNil            = BNil
  266         go (BMiddle n)     = BMiddle $! m n
  267         go (BCat x y)      = (BCat $! go x) $! (go y)
  268         go (BSnoc x n)     = (BSnoc $! go x) $! (m n)
  269         go (BCons n x)     = (BCons $! m n) $! (go x)
  270 
  271 -- -----------------------------------------------------------------------------
  272 -- Folding
  273 
  274 
  275 -- | Fold a function over every node in a block, forward or backward.
  276 -- The fold function must be polymorphic in the shape of the nodes.
  277 foldBlockNodesF3 :: forall n a b c .
  278                    ( n C O       -> a -> b
  279                    , n O O       -> b -> b
  280                    , n O C       -> b -> c)
  281                  -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
  282 foldBlockNodesF  :: forall n a .
  283                     (forall e x . n e x       -> a -> a)
  284                  -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)
  285 foldBlockNodesB3 :: forall n a b c .
  286                    ( n C O       -> b -> c
  287                    , n O O       -> b -> b
  288                    , n O C       -> a -> b)
  289                  -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)
  290 foldBlockNodesB  :: forall n a .
  291                     (forall e x . n e x       -> a -> a)
  292                  -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)
  293 
  294 foldBlockNodesF3 (ff, fm, fl) = block
  295   where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b
  296         block (BlockCO f b  )   = ff f `cat` block b
  297         block (BlockCC f b l)   = ff f `cat` block b `cat` fl l
  298         block (BlockOC   b l)   =            block b `cat` fl l
  299         block BNil              = id
  300         block (BMiddle node)    = fm node
  301         block (b1 `BCat`    b2) = block b1 `cat` block b2
  302         block (b1 `BSnoc` n)    = block b1 `cat` fm n
  303         block (n `BCons` b2)    = fm n `cat` block b2
  304         cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
  305         cat f f' = f' . f
  306 
  307 foldBlockNodesF f = foldBlockNodesF3 (f, f, f)
  308 
  309 foldBlockNodesB3 (ff, fm, fl) = block
  310   where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b
  311         block (BlockCO f b  )   = ff f `cat` block b
  312         block (BlockCC f b l)   = ff f `cat` block b `cat` fl l
  313         block (BlockOC   b l)   =            block b `cat` fl l
  314         block BNil              = id
  315         block (BMiddle node)    = fm node
  316         block (b1 `BCat`    b2) = block b1 `cat` block b2
  317         block (b1 `BSnoc` n)    = block b1 `cat` fm n
  318         block (n `BCons` b2)    = fm n `cat` block b2
  319         cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c
  320         cat f f' = f . f'
  321 
  322 foldBlockNodesB f = foldBlockNodesB3 (f, f, f)
  323