src/Compiler/Hoopl/MkGraph.hs

    {-# LANGUAGE CPP, 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 (Monad(..),liftM2)
    import Prelude (($),(.),foldr,map) -- for the purpose of 'hiding ((<*>))'

    {-|
    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 = (|*><*|)