module Compiler.Hoopl.MkGraph
( AGraph, graphOfAGraph
, (<*>), (|*><*|), catAGraphs, addEntrySeq, addExitSeq, addBlocks, unionBlocks
, emptyAGraph, emptyClosedAGraph, withFreshLabels
, mkFirst, mkMiddle, mkMiddles, mkLast, mkBranch, mkLabel, mkWhileDo
, IfThenElseable(mkIfThenElse)
, mkEntry, mkExit
, HooplNode(mkLabelNode, mkBranchNode)
)
where
import Compiler.Hoopl.Label (Label)
import Compiler.Hoopl.Graph
import Compiler.Hoopl.Fuel
import qualified Compiler.Hoopl.GraphUtil as U
import Control.Monad (liftM2)
newtype AGraph n e x = A { graphOfAGraph :: FuelMonad (Graph n e x) }
class Labels l where
withFreshLabels :: (l -> AGraph n e x) -> AGraph n e x
emptyAGraph :: AGraph n O O
emptyAGraph = A $ return GNil
emptyClosedAGraph :: AGraph n C C
emptyClosedAGraph = A $ return $ GMany NothingO BodyEmpty NothingO
infixl 3 <*>
infixl 2 |*><*|
(<*>) :: AGraph n e O -> AGraph n O x -> AGraph n e x
(|*><*|) :: AGraph n e C -> AGraph n C x -> AGraph n e x
addEntrySeq :: AGraph n O C -> AGraph n C x -> AGraph n O x
addExitSeq :: AGraph n e C -> AGraph n C O -> AGraph n e O
addBlocks :: HooplNode n
=> AGraph n e x -> AGraph n C C -> AGraph n e x
unionBlocks :: AGraph n C C -> AGraph n C C -> AGraph n C C
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')
addEntrySeq = liftA2 U.gSplice
addExitSeq = liftA2 U.gSplice
unionBlocks = liftA2 U.gSplice
addBlocks (A g) (A blocks) = A $ g >>= \g -> blocks >>= add g
where add :: HooplNode n => Graph n e x -> Graph n C C -> FuelMonad (Graph n e x)
add (GMany e body x) (GMany NothingO body' NothingO) =
return $ GMany e (body `BodyCat` body') x
add g@GNil blocks = spliceOO g blocks
add g@(GUnit _) blocks = spliceOO g blocks
spliceOO :: HooplNode n => Graph n O O -> Graph n C C -> FuelMonad(Graph n O O)
spliceOO g blocks = graphOfAGraph $ withFreshLabels $ \l ->
A (return g) <*> mkBranch l |*><*| A (return blocks) |*><*| mkLabel l
mkFirst :: n C O -> AGraph n C O
mkMiddle :: n O O -> AGraph n O O
mkLast :: n O C -> AGraph n O C
mkLabel :: HooplNode n => Label -> AGraph n C O
mkMiddles :: [n O O] -> AGraph n O O
mkEntry :: Block n O C -> AGraph n O C
mkExit :: Block n C O -> AGraph n C O
class Edges n => HooplNode n where
mkBranchNode :: Label -> n O C
mkLabelNode :: Label -> n C O
mkBranch :: HooplNode n => Label -> AGraph n O C
class IfThenElseable x where
mkIfThenElse :: HooplNode n
=> (Label -> Label -> AGraph n O C)
-> AGraph n O x
-> AGraph n O x
-> AGraph n O x
mkWhileDo :: HooplNode n
=> (Label -> Label -> AGraph n O C)
-> AGraph n O O
-> AGraph n O O
(<*>) = liftA2 U.gSplice
(|*><*|) = liftA2 U.gSplice
catAGraphs :: [AGraph n O O] -> AGraph n O O
catAGraphs = foldr (<*>) emptyAGraph
mkLabel id = mkFirst $ mkLabelNode id
mkBranch target = mkLast $ mkBranchNode target
mkMiddles ms = foldr (<*>) emptyAGraph (map mkMiddle ms)
instance IfThenElseable O where
mkIfThenElse cbranch tbranch fbranch = withFreshLabels $ \(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 = withFreshLabels $ \(ltrue, lfalse) ->
cbranch ltrue lfalse |*><*|
mkLabel ltrue <*> tbranch |*><*|
mkLabel lfalse <*> fbranch
mkWhileDo cbranch body = withFreshLabels $ \(test, head, endwhile) ->
mkBranch test |*><*|
mkLabel head <*> body <*> mkBranch test |*><*|
mkLabel test <*> cbranch head endwhile |*><*|
mkLabel endwhile
instance Labels Label where
withFreshLabels f = A $ freshLabel >>= (graphOfAGraph . f)
instance (Labels l1, Labels l2) => Labels (l1, l2) where
withFreshLabels f = withFreshLabels $ \l1 ->
withFreshLabels $ \l2 ->
f (l1, l2)
instance (Labels l1, Labels l2, Labels l3) => Labels (l1, l2, l3) where
withFreshLabels f = withFreshLabels $ \l1 ->
withFreshLabels $ \l2 ->
withFreshLabels $ \l3 ->
f (l1, l2, l3)
instance (Labels l1, Labels l2, Labels l3, Labels l4) => Labels (l1, l2, l3, l4) where
withFreshLabels f = withFreshLabels $ \l1 ->
withFreshLabels $ \l2 ->
withFreshLabels $ \l3 ->
withFreshLabels $ \l4 ->
f (l1, l2, l3, l4)
mkExit block = A $ return $ GMany NothingO BodyEmpty (JustO block)
mkEntry block = A $ return $ GMany (JustO block) BodyEmpty NothingO
mkFirst = mkExit . BUnit
mkLast = mkEntry . BUnit
mkMiddle = A . return . GUnit . BUnit