{-# LANGUAGE ScopedTypeVariables, GADTs, TypeSynonymInstances, FlexibleInstances, RankNTypes #-}moduleCompiler.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))whereimportCompiler.Hoopl.Label(Label,uniqueToLbl)importCompiler.Hoopl.GraphimportqualifiedCompiler.Hoopl.GraphUtilasUimportCompiler.Hoopl.UniqueimportControl.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.
-}classGraphRepgwhere-- | An empty graph that is open at entry and exit. -- It is the left and right identity of '<*>'.emptyGraph::gnOO-- | An empty graph that is closed at entry and exit. -- It is the left and right identity of '|*><*|'.emptyClosedGraph::gnCC-- | Create a graph from a first nodemkFirst::nCO->gnCO-- | Create a graph from a middle nodemkMiddle::nOO->gnOO-- | Create a graph from a last nodemkLast::nOC->gnOCmkFirst=mkExit.BFirstmkLast=mkEntry.BLastinfixl3<*>infixl2|*><*|-- | Concatenate two graphs; control flows from left to right.(<*>)::NonLocaln=>gneO->gnOx->gnex-- | Splice together two graphs at a closed point; nothing is known-- about control flow.(|*><*|)::NonLocaln=>gneC->gnCx->gnex-- | Conveniently concatenate a sequence of open/open graphs using '<*>'.catGraphs::NonLocaln=>[gnOO]->gnOOcatGraphs=foldr(<*>)emptyGraph-- | Create a graph that defines a labelmkLabel::HooplNoden=>Label->gnCO-- definition of the label-- | Create a graph that branches to a labelmkBranch::HooplNoden=>Label->gnOC-- unconditional branch to the label-- | Conveniently concatenate a sequence of middle nodes to form-- an open/open graph.mkMiddles::NonLocaln=>[nOO]->gnOOmkLabelid=mkFirst$mkLabelNodeidmkBranchtarget=mkLast$mkBranchNodetargetmkMiddlesms=catGraphs$mapmkMiddlems-- | Create a graph containing only an entry sequencemkEntry::BlocknOC->gnOC-- | Create a graph containing only an exit sequencemkExit::BlocknCO->gnCOinstanceGraphRepGraphwhereemptyGraph=GNilemptyClosedGraph=GManyNothingOemptyBodyNothingO(<*>)=U.gSplice(|*><*|)=U.gSplicemkMiddle=GUnit.BMiddlemkExitblock=GManyNothingOemptyBody(JustOblock)mkEntryblock=GMany(JustOblock)emptyBodyNothingOinstanceGraphRepAGraphwhereemptyGraph=aGraphOfGraphemptyGraphemptyClosedGraph=aGraphOfGraphemptyClosedGraph(<*>)=liftA2(<*>)(|*><*|)=liftA2(|*><*|)mkMiddle=aGraphOfGraph.mkMiddlemkExit=aGraphOfGraph.mkExitmkEntry=aGraphOfGraph.mkEntry-- | The type of abstract graphs. Offers extra "smart constructors"-- that may consume fresh labels during construction.newtypeAGraphnex=A{graphOfAGraph::forallm.UniqueMonadm=>m(Graphnex)-- ^ Take an abstract 'AGraph'-- and make a concrete (if monadic)-- 'Graph'.}-- | Take a graph and make it abstract.aGraphOfGraph::Graphnex->AGraphnexaGraphOfGraphg=A(returng)-- | 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'.classUniquesuwherewithFresh::(u->AGraphnex)->AGraphnexinstanceUniquesUniquewherewithFreshf=A$freshUnique>>=(graphOfAGraph.f)instanceUniquesLabelwherewithFreshf=A$freshUnique>>=(graphOfAGraph.f.uniqueToLbl)-- | Lifts binary 'Graph' functions into 'AGraph' functions.liftA2::(Graphnab->Graphncd->Graphnef)->(AGraphnab->AGraphncd->AGraphnef)liftA2f(Ag)(Ag')=A(liftM2fgg')-- | Extend an existing 'AGraph' with extra basic blocks "out of line".-- No control flow is implied. Simon PJ should give example use case.addBlocks::HooplNoden=>AGraphnex->AGraphnCC->AGraphnexaddBlocks(Ag)(Ablocks)=A$g>>=\g->blocks>>=addgwhereadd::(UniqueMonadm,HooplNoden)=>Graphnex->GraphnCC->m(Graphnex)add(GManyebodyx)(GManyNothingObody'NothingO)=return$GManye(body`U.bodyUnion`body')xaddg@GNilblocks=spliceOOgblocksaddg@(GUnit_)blocks=spliceOOgblocksspliceOO::(HooplNoden,UniqueMonadm)=>GraphnOO->GraphnCC->m(GraphnOO)spliceOOgblocks=graphOfAGraph$withFresh$\l->A(returng)<*>mkBranchl|*><*|A(returnblocks)|*><*|mkLabell-- | For some graph-construction operations and some optimizations,-- Hoopl must be able to create control-flow edges using a given node-- type 'n'.classNonLocaln=>HooplNodenwhere-- | Create a branch node, the source of a control-flow edge.mkBranchNode::Label->nOC-- | Create a label node, the target (destination) of a control-flow edge.mkLabelNode::Label->nCO---------------------------------------------------------------- Shiny Things--------------------------------------------------------------classIfThenElseablexwhere-- | 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::HooplNoden=>(Label->Label->AGraphnOC)-- ^ branch condition->AGraphnOx-- ^ code in the "then" branch->AGraphnOx-- ^ code in the "else" branch ->AGraphnOx-- ^ resulting if-then-else constructmkWhileDo::HooplNoden=>(Label->Label->AGraphnOC)-- ^ loop condition->AGraphnOO-- ^ body of the loop->AGraphnOO-- ^ the final while loopinstanceIfThenElseableOwheremkIfThenElsecbranchtbranchfbranch=withFresh$\(endif,ltrue,lfalse)->cbranchltruelfalse|*><*|mkLabelltrue<*>tbranch<*>mkBranchendif|*><*|mkLabellfalse<*>fbranch<*>mkBranchendif|*><*|mkLabelendifinstanceIfThenElseableCwheremkIfThenElsecbranchtbranchfbranch=withFresh$\(ltrue,lfalse)->cbranchltruelfalse|*><*|mkLabelltrue<*>tbranch|*><*|mkLabellfalse<*>fbranchmkWhileDocbranchbody=withFresh$\(test,head,endwhile)->-- Forrest Baskett's while-loop layoutmkBranchtest|*><*|mkLabelhead<*>body<*>mkBranchtest|*><*|mkLabeltest<*>cbranchheadendwhile|*><*|mkLabelendwhile---------------------------------------------------------------- Boring instance declarations--------------------------------------------------------------instance(Uniquesu1,Uniquesu2)=>Uniques(u1,u2)wherewithFreshf=withFresh$\u1->withFresh$\u2->f(u1,u2)instance(Uniquesu1,Uniquesu2,Uniquesu3)=>Uniques(u1,u2,u3)wherewithFreshf=withFresh$\u1->withFresh$\u2->withFresh$\u3->f(u1,u2,u3)instance(Uniquesu1,Uniquesu2,Uniquesu3,Uniquesu4)=>Uniques(u1,u2,u3,u4)wherewithFreshf=withFresh$\u1->withFresh$\u2->withFresh$\u3->withFresh$\u4->f(u1,u2,u3,u4)----------------------------------------------- deprecated legacy functions{-# DEPRECATED addEntrySeq, addExitSeq, unionBlocks "use |*><*| instead" #-}addEntrySeq::NonLocaln=>AGraphnOC->AGraphnCx->AGraphnOxaddExitSeq::NonLocaln=>AGraphneC->AGraphnCO->AGraphneOunionBlocks::NonLocaln=>AGraphnCC->AGraphnCC->AGraphnCCaddEntrySeq=(|*><*|)addExitSeq=(|*><*|)unionBlocks=(|*><*|)