MkGraph.hs

{-# LANGUAGE ScopedTypeVariables, GADTs, TypeSynonymInstances, FlexibleInstances, RankNTypes #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif

module Compiler.Hoopl.MkGraph
    ( AGraph, graphOfAGraph, aGraphOfGraph
    , (<*>), (|*><*|), catGraphs, addEntrySeq, addExitSeq, addBlocks, unionBlocks
    , emptyGraph, emptyClosedGraph, withFresh
    , mkFirst, mkMiddle, mkMiddles, mkLast, mkBranch, mkLabel, mkWhileDo
    , IfThenElseable(mkIfThenElse)
    , mkEntry, mkExit
    , HooplNode(mkLabelNode, mkBranchNode)
    )
where

import Compiler.Hoopl.Label (Label, uniqueToLbl)
import Compiler.Hoopl.Block
import Compiler.Hoopl.Graph as U
import Compiler.Hoopl.Unique
import Control.Monad (liftM2)

{-|
As noted in the paper, we can define a single, polymorphic type of 
splicing operation with the very polymorphic type
@
  AGraph n e a -> AGraph n a x -> AGraph n e x
@
However, we feel that this operation is a bit /too/ polymorphic,
and that it's too easy for clients to use it blindly without 
thinking.  We therfore split it into two operations, '<*>' and '|*><*|', 
which are supplemented by other functions:

  * The '<*>' operator is true concatenation, for connecting open graphs.
    Control flows from the left graph to the right graph.

  * The '|*><*|' operator splices together two graphs at a closed
    point. Nothing is known about control flow. The vertical bar
    stands for "closed point" just as the angle brackets above stand
    for "open point".  Unlike the <*> operator, the |*><*| can create
    a control-flow graph with dangling outedges or unreachable blocks.
    The operator must be used carefully, so we have chosen a long name
    on purpose, to help call people's attention to what they're doing.

  * The operator 'addBlocks' adds a set of basic blocks (represented
    as a closed/closed 'AGraph' to an existing graph, without changing
    the shape of the existing graph.  In some cases, it's necessary to
    introduce a branch and a label to 'get around' the blocks added,
    so this operator, and other functions based on it, requires a
    'HooplNode' type-class constraint and is available only on AGraph,
    not Graph.

  * We have discussed a dynamic assertion about dangling outedges and
    unreachable blocks, but nothing is implemented yet.

-}



class GraphRep g where
  -- | An empty graph that is open at entry and exit.  
  -- It is the left and right identity of '<*>'.
  emptyGraph       :: g n O O
  -- | An empty graph that is closed at entry and exit.  
  -- It is the left and right identity of '|*><*|'.
  emptyClosedGraph :: g n C C
  -- | Create a graph from a first node
  mkFirst  :: n C O -> g n C O
  -- | Create a graph from a middle node
  mkMiddle :: n O O -> g n O O
  -- | Create a graph from a last node
  mkLast   :: n O C -> g n O C
  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.
  (<*>)    :: NonLocal n => g n e O -> g n O x -> g n e x
  -- | Splice together two graphs at a closed point; nothing is known
  -- about control flow.
  (|*><*|) :: NonLocal n => g n e C -> g n C x -> g n e x
  -- | Conveniently concatenate a sequence of open/open graphs using '<*>'.
  catGraphs :: NonLocal n => [g n O O] -> g n O O
  catGraphs = foldr (<*>) emptyGraph

  -- | Create a graph that defines a label
  mkLabel  :: HooplNode n => Label -> g n C O -- definition of the label
  -- | Create a graph that branches to a label
  mkBranch :: HooplNode n => Label -> g n O C -- unconditional branch to the label

  -- | Conveniently concatenate a sequence of middle nodes to form
  -- an open/open graph.
  mkMiddles :: NonLocal n => [n O O] -> g n O O

  mkLabel  id     = mkFirst $ mkLabelNode id
  mkBranch target = mkLast  $ mkBranchNode target
  mkMiddles ms    = catGraphs $ map mkMiddle ms

  -- | Create a graph containing only an entry sequence
  mkEntry   :: Block n O C -> g n O C
  -- | Create a graph containing only an exit sequence
  mkExit    :: Block n C O -> g n C O

instance GraphRep Graph where
  emptyGraph  = GNil
  emptyClosedGraph = GMany NothingO emptyBody NothingO
  (<*>)       = U.gSplice
  (|*><*|)    = U.gSplice
  mkMiddle    = GUnit . BMiddle
  mkExit   block = GMany NothingO      emptyBody (JustO block)
  mkEntry  block = GMany (JustO block) emptyBody NothingO

instance GraphRep AGraph where
  emptyGraph  = aGraphOfGraph emptyGraph
  emptyClosedGraph = aGraphOfGraph emptyClosedGraph
  (<*>)       = liftA2 (<*>)
  (|*><*|)    = liftA2 (|*><*|)
  mkMiddle    = aGraphOfGraph . mkMiddle
  mkExit  = aGraphOfGraph . mkExit
  mkEntry = aGraphOfGraph . mkEntry


-- | The type of abstract graphs.  Offers extra "smart constructors"
-- that may consume fresh labels during construction.
newtype AGraph n e x =
  A { graphOfAGraph :: forall m. UniqueMonad m =>
                       m (Graph n e x) -- ^ Take an abstract 'AGraph'
                                       -- and make a concrete (if monadic)
                                       -- 'Graph'.
    }

-- | Take a graph and make it abstract.
aGraphOfGraph :: Graph n e x -> AGraph n e x
aGraphOfGraph g = A (return g)


-- | The 'Labels' class defines things that can be lambda-bound
-- by an argument to 'withFreshLabels'.  Such an argument may
-- lambda-bind a single 'Label', or if multiple labels are needed,
-- it can bind a tuple.  Tuples can be nested, so arbitrarily many
-- fresh labels can be acquired in a single call.
-- 
-- For example usage see implementations of 'mkIfThenElse' and 'mkWhileDo'.
class Uniques u where
  withFresh :: (u -> AGraph n e x) -> AGraph n e x

instance Uniques Unique where
  withFresh f = A $ freshUnique >>= (graphOfAGraph . f)

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)
       -> (AGraph n a b -> AGraph n c d -> AGraph n e f)
liftA2 f (A g) (A g') = A (liftM2 f g g')

-- | Extend an existing 'AGraph' with extra basic blocks "out of line".
-- No control flow is implied.  Simon PJ should give example use case.
addBlocks      :: HooplNode n
               => AGraph n e x -> AGraph n C C -> AGraph n e x
addBlocks (A g) (A blocks) = A $ g >>= \g -> blocks >>= add g
  where add :: (UniqueMonad m, HooplNode n)
            => Graph n e x -> Graph n C C -> m (Graph n e x)
        add (GMany e body x) (GMany NothingO body' NothingO) =
          return $ GMany e (body `U.bodyUnion` body') x
        add g@GNil      blocks = spliceOO g blocks
        add g@(GUnit _) blocks = spliceOO g blocks
        spliceOO :: (HooplNode n, UniqueMonad m)
                 => Graph n O O -> Graph n C C -> m (Graph n O O)
        spliceOO g blocks = graphOfAGraph $ withFresh $ \l ->
          A (return g) <*> mkBranch l |*><*| A (return blocks) |*><*| mkLabel l

-- | For some graph-construction operations and some optimizations,
-- Hoopl must be able to create control-flow edges using a given node
-- type 'n'.
class NonLocal n => HooplNode n where
  -- | Create a branch node, the source of a control-flow edge.
  mkBranchNode :: Label -> n O C
  -- | Create a label node, the target (destination) of a control-flow edge.
  mkLabelNode  :: Label -> n C O

--------------------------------------------------------------
--                   Shiny Things
--------------------------------------------------------------

class IfThenElseable x where
  -- | Translate a high-level if-then-else construct into an 'AGraph'.
  -- The condition takes as arguments labels on the true-false branch
  -- and returns a single-entry, two-exit graph which exits to 
  -- the two labels.
  mkIfThenElse :: HooplNode n
               => (Label -> Label -> AGraph n O C) -- ^ branch condition
               -> AGraph n O x   -- ^ code in the "then" branch
               -> AGraph n O x   -- ^ code in the "else" branch 
               -> AGraph n O x   -- ^ resulting if-then-else construct

mkWhileDo    :: HooplNode n
             => (Label -> Label -> AGraph n O C) -- ^ loop condition
             -> AGraph n O O -- ^ body of the loop
             -> AGraph n O O -- ^ the final while loop

instance IfThenElseable O where
  mkIfThenElse cbranch tbranch fbranch = withFresh $ \(endif, ltrue, lfalse) ->
    cbranch ltrue lfalse |*><*|
      mkLabel ltrue  <*> tbranch <*> mkBranch endif |*><*|
      mkLabel lfalse <*> fbranch <*> mkBranch endif |*><*|
      mkLabel endif

instance IfThenElseable C where
  mkIfThenElse cbranch tbranch fbranch = withFresh $ \(ltrue, lfalse) ->
    cbranch ltrue lfalse |*><*|
       mkLabel ltrue  <*> tbranch |*><*|
       mkLabel lfalse <*> fbranch

mkWhileDo cbranch body = withFresh $ \(test, head, endwhile) ->
     -- Forrest Baskett's while-loop layout
  mkBranch test |*><*|
    mkLabel head <*> body <*> mkBranch test |*><*|
    mkLabel test <*> cbranch head endwhile  |*><*|
    mkLabel endwhile

--------------------------------------------------------------
--               Boring instance declarations
--------------------------------------------------------------


instance (Uniques u1, Uniques u2) => Uniques (u1, u2) where
  withFresh f = withFresh $ \u1 ->
                withFresh $ \u2 ->
                f (u1, u2)

instance (Uniques u1, Uniques u2, Uniques u3) => Uniques (u1, u2, u3) where
  withFresh f = withFresh $ \u1 ->
                withFresh $ \u2 ->
                withFresh $ \u3 ->
                f (u1, u2, u3)

instance (Uniques u1, Uniques u2, Uniques u3, Uniques u4) => Uniques (u1, u2, u3, u4) where
  withFresh f = withFresh $ \u1 ->
                withFresh $ \u2 ->
                withFresh $ \u3 ->
                withFresh $ \u4 ->
                f (u1, u2, u3, u4)

---------------------------------------------
-- deprecated legacy functions

{-# DEPRECATED addEntrySeq, addExitSeq, unionBlocks "use |*><*| instead" #-}
addEntrySeq :: NonLocal n => AGraph n O C -> AGraph n C x -> AGraph n O x
addExitSeq  :: NonLocal n => AGraph n e C -> AGraph n C O -> AGraph n e O
unionBlocks :: NonLocal n => AGraph n C C -> AGraph n C C -> AGraph n C C

addEntrySeq = (|*><*|)
addExitSeq  = (|*><*|)
unionBlocks = (|*><*|)