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