{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-}#if __GLASGOW_HASKELL__ >= 703{- OPTIONS_GHC -fprof-auto #-}#endif#if __GLASGOW_HASKELL__ >= 701{-# LANGUAGE Trustworthy #-}#endif#if __GLASGOW_HASKELL__ < 701{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}#endifmoduleCompiler.Hoopl.Dataflow(DataflowLattice(..),JoinFun,OldFact(..),NewFact(..),Fact,mkFactBase,ChangeFlag(..),changeIf,FwdPass(..),FwdTransfer(..),mkFTransfer,mkFTransfer3,FwdRewrite(..),mkFRewrite,mkFRewrite3,noFwdRewrite,wrapFR,wrapFR2,BwdPass(..),BwdTransfer(..),mkBTransfer,mkBTransfer3,wrapBR,wrapBR2,BwdRewrite(..),mkBRewrite,mkBRewrite3,noBwdRewrite,analyzeAndRewriteFwd,analyzeAndRewriteBwd-- * Respecting Fuel-- $fuel)whereimportCompiler.Hoopl.BlockimportCompiler.Hoopl.CollectionsimportCompiler.Hoopl.CheckpointimportCompiler.Hoopl.FuelimportCompiler.Hoopl.Graphhiding(Graph)-- hiding so we can redefine-- and include definition in paperimportCompiler.Hoopl.LabelimportControl.MonadimportData.Maybe------------------------------------------------------------------------------- DataflowLattice-----------------------------------------------------------------------------dataDataflowLatticea=DataflowLattice{fact_name::String-- Documentation,fact_bot::a-- Lattice bottom element,fact_join::JoinFuna-- Lattice join plus change flag-- (changes iff result > old fact)}-- ^ A transfer function might want to use the logging flag-- to control debugging, as in for example, it updates just one element-- in a big finite map. We don't want Hoopl to show the whole fact,-- and only the transfer function knows exactly what changed.typeJoinFuna=Label->OldFacta->NewFacta->(ChangeFlag,a)-- the label argument is for debugging purposes onlynewtypeOldFacta=OldFactanewtypeNewFacta=NewFactadataChangeFlag=NoChange|SomeChangederiving(Eq,Ord)changeIf::Bool->ChangeFlagchangeIfchanged=ifchangedthenSomeChangeelseNoChange-- | 'mkFactBase' creates a 'FactBase' from a list of ('Label', fact)-- pairs. If the same label appears more than once, the relevant facts-- are joined.mkFactBase::forallf.DataflowLatticef->[(Label,f)]->FactBasefmkFactBaselattice=foldladdmapEmptywhereadd::FactBasef->(Label,f)->FactBasefaddmap(lbl,f)=mapInsertlblnewFactmapwherenewFact=casemapLookuplblmapofNothing->fJustf'->snd$joinlbl(OldFactf')(NewFactf)join=fact_joinlattice------------------------------------------------------------------------------- Analyze and rewrite forward: the interface-----------------------------------------------------------------------------dataFwdPassmnf=FwdPass{fp_lattice::DataflowLatticef,fp_transfer::FwdTransfernf,fp_rewrite::FwdRewritemnf}newtypeFwdTransfernf=FwdTransfer3{getFTransfer3::(nCO->f->f,nOO->f->f,nOC->f->FactBasef)}newtypeFwdRewritemnf-- see Note [Respects Fuel]=FwdRewrite3{getFRewrite3::(nCO->f->m(Maybe(GraphnCO,FwdRewritemnf)),nOO->f->m(Maybe(GraphnOO,FwdRewritemnf)),nOC->f->m(Maybe(GraphnOC,FwdRewritemnf)))}{-# INLINE wrapFR #-}wrapFR::(forallex.(nex->f->m(Maybe(Graphnex,FwdRewritemnf)))->(n'ex->f'->m'(Maybe(Graphn'ex,FwdRewritem'n'f'))))-- ^ This argument may assume that any function passed to it-- respects fuel, and it must return a result that respects fuel.->FwdRewritemnf->FwdRewritem'n'f'-- see Note [Respects Fuel]wrapFRwrap(FwdRewrite3(f,m,l))=FwdRewrite3(wrapf,wrapm,wrapl){-# INLINE wrapFR2 #-}wrapFR2::(forallex.(n1ex->f1->m1(Maybe(Graphn1ex,FwdRewritem1n1f1)))->(n2ex->f2->m2(Maybe(Graphn2ex,FwdRewritem2n2f2)))->(n3ex->f3->m3(Maybe(Graphn3ex,FwdRewritem3n3f3))))-- ^ This argument may assume that any function passed to it-- respects fuel, and it must return a result that respects fuel.->FwdRewritem1n1f1->FwdRewritem2n2f2->FwdRewritem3n3f3-- see Note [Respects Fuel]wrapFR2wrap2(FwdRewrite3(f1,m1,l1))(FwdRewrite3(f2,m2,l2))=FwdRewrite3(wrap2f1f2,wrap2m1m2,wrap2l1l2)mkFTransfer3::(nCO->f->f)->(nOO->f->f)->(nOC->f->FactBasef)->FwdTransfernfmkFTransfer3fml=FwdTransfer3(f,m,l)mkFTransfer::(forallex.nex->f->Factxf)->FwdTransfernfmkFTransferf=FwdTransfer3(f,f,f)-- | Functions passed to 'mkFRewrite3' should not be aware of the fuel supply.-- The result returned by 'mkFRewrite3' respects fuel.mkFRewrite3::forallmnf.FuelMonadm=>(nCO->f->m(Maybe(GraphnCO)))->(nOO->f->m(Maybe(GraphnOO)))->(nOC->f->m(Maybe(GraphnOC)))->FwdRewritemnfmkFRewrite3fml=FwdRewrite3(liftf,liftm,liftl)wherelift::foralltt1a.(t->t1->m(Maybea))->t->t1->m(Maybe(a,FwdRewritemnf))liftrwnodefact=liftM(liftMasRew)(withFuel=<<rwnodefact)asRew::forallt.t->(t,FwdRewritemnf)asRewg=(g,noFwdRewrite)noFwdRewrite::Monadm=>FwdRewritemnfnoFwdRewrite=FwdRewrite3(noRewrite,noRewrite,noRewrite)noRewrite::Monadm=>a->b->m(Maybec)noRewrite__=returnNothing-- | Functions passed to 'mkFRewrite' should not be aware of the fuel supply.-- The result returned by 'mkFRewrite' respects fuel.mkFRewrite::FuelMonadm=>(forallex.nex->f->m(Maybe(Graphnex)))->FwdRewritemnfmkFRewritef=mkFRewrite3ffftypefamilyFactxf::*typeinstanceFactCf=FactBaseftypeinstanceFactOf=f-- | if the graph being analyzed is open at the entry, there must-- be no other entry point, or all goes horribly wrong...analyzeAndRewriteFwd::forallmnfexentries.(CheckpointMonadm,NonLocaln,LabelsPtrentries)=>FwdPassmnf->MaybeCeentries->Graphnex->Factef->m(Graphnex,FactBasef,MaybeOxf)analyzeAndRewriteFwdpassentriesgf=do(rg,fout)<-arfGraphpass(fmaptargetLabelsentries)gflet(g',fb)=normalizeGraphrgreturn(g',fb,distinguishedExitFactg'fout)distinguishedExitFact::forallnexf.Graphnex->Factxf->MaybeOxfdistinguishedExitFactgf=maybegwheremaybe::Graphnex->MaybeOxfmaybeGNil=JustOfmaybe(GUnit{})=JustOfmaybe(GMany__x)=casexofNothingO->NothingOJustO_->JustOf------------------------------------------------------------------ Forward Implementation----------------------------------------------------------------typeEntriese=MaybeCe[Label]arfGraph::forallmnfex.(NonLocaln,CheckpointMonadm)=>FwdPassmnf->Entriese->Graphnex->Factef->m(DGfnex,Factxf)arfGraphpass@FwdPass{fp_lattice=lattice,fp_transfer=transfer,fp_rewrite=rewrite}entries=graphwhere{- nested type synonyms would be so lovely here
type ARF thing = forall e x . thing e x -> f -> m (DG f n e x, Fact x f)
type ARFX thing = forall e x . thing e x -> Fact e f -> m (DG f n e x, Fact x f)
-}graph::Graphnex->Factef->m(DGfnex,Factxf)-- @ start block.tex -2block::forallex.Blocknex->f->m(DGfnex,Factxf)-- @ end block.tex-- @ start node.tex -4node::forallex.(ShapeLifterex)=>nex->f->m(DGfnex,Factxf)-- @ end node.tex-- @ start bodyfun.texbody::[Label]->LabelMap(BlocknCC)->FactCf->m(DGfnCC,FactCf)-- @ end bodyfun.tex-- Outgoing factbase is restricted to Labels *not* in-- in the Body; the facts for Labels *in*-- the Body are in the 'DG f n C C'-- @ start cat.tex -2cat::foralleaxf1f2f3.(f1->m(DGfnea,f2))->(f2->m(DGfnax,f3))->(f1->m(DGfnex,f3))-- @ end cat.texgraphGNil=\f->return(dgnil,f)graph(GUnitblk)=blockblkgraph(GManyebdyx)=(e`ebcat`bdy)`cat`exitxwhereebcat::MaybeOe(BlocknOC)->Bodyn->Factef->m(DGfneC,FactCf)exit::MaybeOx(BlocknCO)->FactCf->m(DGfnCx,Factxf)exit(JustOblk)=arfxblockblkexitNothingO=\fb->return(dgnilC,fb)ebcatentrybdy=centriesentrywherec::MaybeCe[Label]->MaybeOe(BlocknOC)->Factef->m(DGfneC,FactCf)cNothingC(JustOentry)=blockentry`cat`body(successorsentry)bdyc(JustCentries)NothingO=bodyentriesbdyc__=error"bogus GADT pattern match failure"-- Lift from nodes to blocks-- @ start block.tex -2blockBNil=\f->return(dgnil,f)block(BlockCOlb)=nodel`cat`blockbblock(BlockCClbn)=nodel`cat`blockb`cat`nodenblock(BlockOCbn)=blockb`cat`nodenblock(BMiddlen)=nodenblock(BCatb1b2)=blockb1`cat`blockb2-- @ end block.texblock(BSnochn)=blockh`cat`nodenblock(BConsnt)=noden`cat`blockt-- @ start node.tex -4nodenf=do{grw<-frewriterewritenf;casegrwofNothing->return(singletonDGfn,ftransfertransfernf)Just(g,rw)->letpass'=pass{fp_rewrite=rw}f'=fwdEntryFactnfinarfGraphpass'(fwdEntryLabeln)gf'}-- @ end node.tex-- | Compose fact transformers and concatenate the resulting-- rewritten graphs.{-# INLINE cat #-}-- @ start cat.tex -2catft1ft2f=do{(g1,f1)<-ft1f;(g2,f2)<-ft2f1;return(g1`dgSplice`g2,f2)}-- @ end cat.texarfx::forallthingx.NonLocalthing=>(thingCx->f->m(DGfnCx,Factxf))->(thingCx->FactCf->m(DGfnCx,Factxf))arfxarfthingfb=arfthing$fromJust$lookupFact(entryLabelthing)$joinInFactslatticefb-- joinInFacts adds debugging information-- Outgoing factbase is restricted to Labels *not* in-- in the Body; the facts for Labels *in*-- the Body are in the 'DG f n C C'-- @ start bodyfun.texbodyentriesblockmapinit_fbase=fixpointFwdlatticedo_blockentriesblockmapinit_fbasewheredo_block::forallx.BlocknCx->FactBasef->m(DGfnCx,Factxf)do_blockbfb=blockbentryFactwhereentryFact=getFactlattice(entryLabelb)fb-- @ end bodyfun.tex-- Join all the incoming facts with bottom.-- We know the results _shouldn't change_, but the transfer-- functions might, for example, generate some debugging traces.joinInFacts::DataflowLatticef->FactBasef->FactBasefjoinInFacts(lattice@DataflowLattice{fact_bot=bot,fact_join=fj})fb=mkFactBaselattice$mapbotJoin$mapToListfbwherebotJoin(l,f)=(l,snd$fjl(OldFactbot)(NewFactf))forwardBlockList::(NonLocaln,LabelsPtrentry)=>entry->Bodyn->[BlocknCC]-- This produces a list of blocks in order suitable for forward analysis,-- along with the list of Labels it may depend on for facts.forwardBlockListentriesblks=postorder_dfs_fromblksentries------------------------------------------------------------------------------- Backward analysis and rewriting: the interface-----------------------------------------------------------------------------dataBwdPassmnf=BwdPass{bp_lattice::DataflowLatticef,bp_transfer::BwdTransfernf,bp_rewrite::BwdRewritemnf}newtypeBwdTransfernf=BwdTransfer3{getBTransfer3::(nCO->f->f,nOO->f->f,nOC->FactBasef->f)}newtypeBwdRewritemnf=BwdRewrite3{getBRewrite3::(nCO->f->m(Maybe(GraphnCO,BwdRewritemnf)),nOO->f->m(Maybe(GraphnOO,BwdRewritemnf)),nOC->FactBasef->m(Maybe(GraphnOC,BwdRewritemnf)))}{-# INLINE wrapBR #-}wrapBR::(forallex.Shapex->(nex->Factxf->m(Maybe(Graphnex,BwdRewritemnf)))->(n'ex->Factxf'->m'(Maybe(Graphn'ex,BwdRewritem'n'f'))))-- ^ This argument may assume that any function passed to it-- respects fuel, and it must return a result that respects fuel.->BwdRewritemnf->BwdRewritem'n'f'-- see Note [Respects Fuel]wrapBRwrap(BwdRewrite3(f,m,l))=BwdRewrite3(wrapOpenf,wrapOpenm,wrapClosedl){-# INLINE wrapBR2 #-}wrapBR2::(forallex.Shapex->(n1ex->Factxf1->m1(Maybe(Graphn1ex,BwdRewritem1n1f1)))->(n2ex->Factxf2->m2(Maybe(Graphn2ex,BwdRewritem2n2f2)))->(n3ex->Factxf3->m3(Maybe(Graphn3ex,BwdRewritem3n3f3))))-- ^ This argument may assume that any function passed to it-- respects fuel, and it must return a result that respects fuel.->BwdRewritem1n1f1->BwdRewritem2n2f2->BwdRewritem3n3f3-- see Note [Respects Fuel]wrapBR2wrap2(BwdRewrite3(f1,m1,l1))(BwdRewrite3(f2,m2,l2))=BwdRewrite3(wrap2Openf1f2,wrap2Openm1m2,wrap2Closedl1l2)mkBTransfer3::(nCO->f->f)->(nOO->f->f)->(nOC->FactBasef->f)->BwdTransfernfmkBTransfer3fml=BwdTransfer3(f,m,l)mkBTransfer::(forallex.nex->Factxf->f)->BwdTransfernfmkBTransferf=BwdTransfer3(f,f,f)-- | Functions passed to 'mkBRewrite3' should not be aware of the fuel supply.-- The result returned by 'mkBRewrite3' respects fuel.mkBRewrite3::forallmnf.FuelMonadm=>(nCO->f->m(Maybe(GraphnCO)))->(nOO->f->m(Maybe(GraphnOO)))->(nOC->FactBasef->m(Maybe(GraphnOC)))->BwdRewritemnfmkBRewrite3fml=BwdRewrite3(liftf,liftm,liftl)wherelift::foralltt1a.(t->t1->m(Maybea))->t->t1->m(Maybe(a,BwdRewritemnf))liftrwnodefact=liftM(liftMasRew)(withFuel=<<rwnodefact)asRew::t->(t,BwdRewritemnf)asRewg=(g,noBwdRewrite)noBwdRewrite::Monadm=>BwdRewritemnfnoBwdRewrite=BwdRewrite3(noRewrite,noRewrite,noRewrite)-- | Functions passed to 'mkBRewrite' should not be aware of the fuel supply.-- The result returned by 'mkBRewrite' respects fuel.mkBRewrite::FuelMonadm=>(forallex.nex->Factxf->m(Maybe(Graphnex)))->BwdRewritemnfmkBRewritef=mkBRewrite3fff------------------------------------------------------------------------------- Backward implementation-----------------------------------------------------------------------------arbGraph::forallmnfex.(NonLocaln,CheckpointMonadm)=>BwdPassmnf->Entriese->Graphnex->Factxf->m(DGfnex,Factef)arbGraphpass@BwdPass{bp_lattice=lattice,bp_transfer=transfer,bp_rewrite=rewrite}entries=graphwhere{- nested type synonyms would be so lovely here
type ARB thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, f)
type ARBX thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, Fact e f)
-}graph::Graphnex->Factxf->m(DGfnex,Factef)block::forallex.Blocknex->Factxf->m(DGfnex,f)node::forallex.(ShapeLifterex)=>nex->Factxf->m(DGfnex,f)body::[Label]->Bodyn->FactCf->m(DGfnCC,FactCf)cat::foralleaxinfoinfo'info''.(info'->m(DGfnea,info''))->(info->m(DGfnax,info'))->(info->m(DGfnex,info''))graphGNil=\f->return(dgnil,f)graph(GUnitblk)=blockblkgraph(GManyebdyx)=(e`ebcat`bdy)`cat`exitxwhereebcat::MaybeOe(BlocknOC)->Bodyn->FactCf->m(DGfneC,Factef)exit::MaybeOx(BlocknCO)->Factxf->m(DGfnCx,FactCf)exit(JustOblk)=arbxblockblkexitNothingO=\fb->return(dgnilC,fb)ebcatentrybdy=centriesentrywherec::MaybeCe[Label]->MaybeOe(BlocknOC)->FactCf->m(DGfneC,Factef)cNothingC(JustOentry)=blockentry`cat`body(successorsentry)bdyc(JustCentries)NothingO=bodyentriesbdyc__=error"bogus GADT pattern match failure"-- Lift from nodes to blocksblockBNil=\f->return(dgnil,f)block(BlockCOlb)=nodel`cat`blockbblock(BlockCClbn)=nodel`cat`blockb`cat`nodenblock(BlockOCbn)=blockb`cat`nodenblock(BMiddlen)=nodenblock(BCatb1b2)=blockb1`cat`blockb2block(BSnochn)=blockh`cat`nodenblock(BConsnt)=noden`cat`blocktnodenf=do{bwdres<-brewriterewritenf;casebwdresofNothing->return(singletonDGentry_fn,entry_f)whereentry_f=btransfertransfernfJust(g,rw)->do{letpass'=pass{bp_rewrite=rw};(g,f)<-arbGraphpass'(fwdEntryLabeln)gf;return(g,bwdEntryFactlatticenf)}}-- | Compose fact transformers and concatenate the resulting-- rewritten graphs.{-# INLINE cat #-}catft1ft2f=do{(g2,f2)<-ft2f;(g1,f1)<-ft1f2;return(g1`dgSplice`g2,f1)}arbx::forallthingx.NonLocalthing=>(thingCx->Factxf->m(DGfnCx,f))->(thingCx->Factxf->m(DGfnCx,FactCf))arbxarbthingf=do{(rg,f)<-arbthingf;letfb=joinInFactslattice$mapSingleton(entryLabelthing)f;return(rg,fb)}-- joinInFacts adds debugging information-- Outgoing factbase is restricted to Labels *not* in-- in the Body; the facts for Labels *in*-- the Body are in the 'DG f n C C'bodyentriesblockmapinit_fbase=fixpointBwdlatticedo_block(mapentryLabel(backwardBlockListentriesblockmap))blockmapinit_fbasewheredo_block::forallx.BlocknCx->Factxf->m(DGfnCx,LabelMapf)do_blockbf=do(g,f)<-blockbfreturn(g,mapSingleton(entryLabelb)f)backwardBlockList::(LabelsPtrentries,NonLocaln)=>entries->Bodyn->[BlocknCC]-- This produces a list of blocks in order suitable for backward analysis,-- along with the list of Labels it may depend on for facts.backwardBlockListentriesbody=reverse$forwardBlockListentriesbody{-
The forward and backward cases are not dual. In the forward case, the
entry points are known, and one simply traverses the body blocks from
those points. In the backward case, something is known about the exit
points, but this information is essentially useless, because we don't
actually have a dual graph (that is, one with edges reversed) to
compute with. (Even if we did have a dual graph, it would not avail
us---a backward analysis must include reachable blocks that don't
reach the exit, as in a procedure that loops forever and has side
effects.)
-}-- | if the graph being analyzed is open at the exit, I don't-- quite understand the implications of possible other exitsanalyzeAndRewriteBwd::(CheckpointMonadm,NonLocaln,LabelsPtrentries)=>BwdPassmnf->MaybeCeentries->Graphnex->Factxf->m(Graphnex,FactBasef,MaybeOef)analyzeAndRewriteBwdpassentriesgf=do(rg,fout)<-arbGraphpass(fmaptargetLabelsentries)gflet(g',fb)=normalizeGraphrgreturn(g',fb,distinguishedEntryFactg'fout)distinguishedEntryFact::forallnexf.Graphnex->Factef->MaybeOefdistinguishedEntryFactgf=maybegwheremaybe::Graphnex->MaybeOefmaybeGNil=JustOfmaybe(GUnit{})=JustOfmaybe(GManye__)=caseeofNothingO->NothingOJustO_->JustOf------------------------------------------------------------------------------- fixpoint: finding fixed points------------------------------------------------------------------------------- See Note [TxFactBase invariants]updateFact::DataflowLatticef->LabelMap(DBlockfnCC)->Label->f-- out fact->([Label],FactBasef)->([Label],FactBasef)-- See Note [TxFactBase change flag]updateFactlatnewblockslblnew_fact(cha,fbase)|NoChange<-cha2,lbl`mapMember`newblocks=(cha,fbase)|otherwise=(lbl:cha,mapInsertlblres_factfbase)where(cha2,res_fact)-- Note [Unreachable blocks]=caselookupFactlblfbaseofNothing->(SomeChange,new_fact_debug)-- Note [Unreachable blocks]Justold_fact->joinold_factwherejoinold_fact=fact_joinlatlbl(OldFactold_fact)(NewFactnew_fact)(_,new_fact_debug)=join(fact_botlat){-
-- this doesn't work because it can't be implemented
class Monad m => FixpointMonad m where
observeChangedFactBase :: m (Maybe (FactBase f)) -> Maybe (FactBase f)
-}-- @ start fptype.texdataDirection=Fwd|Bwdfixpoint::forallmnf.(CheckpointMonadm,NonLocaln)=>Direction->DataflowLatticef->(BlocknCC->FactCf->m(DGfnCC,FactCf))->[Label]->LabelMap(BlocknCC)->(FactCf->m(DGfnCC,FactCf))-- @ end fptype.tex-- @ start fpimp.texfixpointdirectionlatdo_blockentriesblockmapinit_fbase=do-- trace ("fixpoint: " ++ show (case direction of Fwd -> True; Bwd -> False) ++ " " ++ show (mapKeys blockmap) ++ show entries ++ " " ++ show (mapKeys init_fbase)) $ return()(fbase,newblocks)<-loopinit_fbaseentriesmapEmpty-- trace ("fixpoint DONE: " ++ show (mapKeys fbase) ++ show (mapKeys newblocks)) $ return()return(GManyNothingOnewblocksNothingO,mapDeleteList(mapKeysblockmap)fbase)-- The successors of the Graph are the the Labels-- for which we have facts and which are *not* in-- the blocks of the graphwhere-- mapping from L -> Ls. If the fact for L changes, re-analyse Ls.dep_blocks::LabelMap[Label]dep_blocks=mapFromListWith(++)[(l,[entryLabelb])|b<-mapElemsblockmap,l<-casedirectionofFwd->[entryLabelb]Bwd->successorsb]loop::FactBasef-- current factbase (increases monotonically)->[Label]-- blocks still to analyse (Todo: use a better rep)->LabelMap(DBlockfnCC)-- transformed graph->m(FactBasef,LabelMap(DBlockfnCC))loopfbase[]newblocks=return(fbase,newblocks)loopfbase(lbl:todo)newblocks=docasemapLookuplblblockmapofNothing->loopfbasetodonewblocksJustblk->do-- trace ("analysing: " ++ show lbl) $ return ()(rg,out_facts)<-do_blockblkfbaselet(changed,fbase')=mapFoldWithKey(updateFactlatnewblocks)([],fbase)out_facts-- trace ("fbase': " ++ show (mapKeys fbase')) $ return ()-- trace ("changed: " ++ show changed) $ return ()letto_analyse=filter(`notElem`todo)$concatMap(\l->mapFindWithDefault[]ldep_blocks)changed-- trace ("to analyse: " ++ show to_analyse) $ return ()letnewblocks'=casergofGMany_blks_->mapUnionblksnewblocksloopfbase'(todo++to_analyse)newblocks'{- Note [TxFactBase invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The TxFactBase is used only during a fixpoint iteration (or "sweep"),
and accumulates facts (and the transformed code) during the fixpoint
iteration.
* tfb_fbase increases monotonically, across all sweeps
* At the beginning of each sweep
tfb_cha = NoChange
tfb_lbls = {}
* During each sweep we process each block in turn. Processing a block
is done thus:
1. Read from tfb_fbase the facts for its entry label (forward)
or successors labels (backward)
2. Transform those facts into new facts for its successors (forward)
or entry label (backward)
3. Augment tfb_fbase with that info
We call the labels read in step (1) the "in-labels" of the sweep
* The field tfb_lbls is the set of in-labels of all blocks that have
been processed so far this sweep, including the block that is
currently being processed. tfb_lbls is initialised to {}. It is a
subset of the Labels of the *original* (not transformed) blocks.
* The tfb_cha field is set to SomeChange iff we decide we need to
perform another iteration of the fixpoint loop. It is initialsed to NoChange.
Specifically, we set tfb_cha to SomeChange in step (3) iff
(a) The fact in tfb_fbase for a block L changes
(b) L is in tfb_lbls
Reason: until a label enters the in-labels its accumuated fact in tfb_fbase
has not been read, hence cannot affect the outcome
Note [Unreachable blocks]
~~~~~~~~~~~~~~~~~~~~~~~~~
A block that is not in the domain of tfb_fbase is "currently unreachable".
A currently-unreachable block is not even analyzed. Reason: consider
constant prop and this graph, with entry point L1:
L1: x:=3; goto L4
L2: x:=4; goto L4
L4: if x>3 goto L2 else goto L5
Here L2 is actually unreachable, but if we process it with bottom input fact,
we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
* If a currently-unreachable block is not analyzed, then its rewritten
graph will not be accumulated in tfb_rg. And that is good:
unreachable blocks simply do not appear in the output.
* Note that clients must be careful to provide a fact (even if bottom)
for each entry point. Otherwise useful blocks may be garbage collected.
* Note that updateFact must set the change-flag if a label goes from
not-in-fbase to in-fbase, even if its fact is bottom. In effect the
real fact lattice is
UNR
bottom
the points above bottom
* Even if the fact is going from UNR to bottom, we still call the
client's fact_join function because it might give the client
some useful debugging information.
* All of this only applies for *forward* fixpoints. For the backward
case we must treat every block as reachable; it might finish with a
'return', and therefore have no successors, for example.
-}------------------------------------------------------------------------------- DG: an internal data type for 'decorated graphs'-- TOTALLY internal to Hoopl; each block is decorated with a fact------------------------------------------------------------------------------- @ start dg.textypeGraph=Graph'BlocktypeDGf=Graph'(DBlockf)dataDBlockfnex=DBlockf(Blocknex)-- ^ block decorated with fact-- @ end dg.texinstanceNonLocaln=>NonLocal(DBlockfn)whereentryLabel(DBlock_b)=entryLabelbsuccessors(DBlock_b)=successorsb--- constructorsdgnil::DGfnOOdgnilC::DGfnCCdgSplice::NonLocaln=>DGfnea->DGfnax->DGfnex---- observersnormalizeGraph::forallnfex.NonLocaln=>DGfnex->(Graphnex,FactBasef)-- A Graph together with the facts for that graph-- The domains of the two maps should be identicalnormalizeGraphg=(mapGraphBlocksdropFactg,factsg)wheredropFact::DBlocktt1t2t3->Blockt1t2t3dropFact(DBlock_b)=bfacts::DGfnex->FactBaseffactsGNil=noFactsfacts(GUnit_)=noFactsfacts(GMany_bodyexit)=bodyFactsbody`mapUnion`exitFactsexitexitFacts::MaybeOx(DBlockfnCO)->FactBasefexitFactsNothingO=noFactsexitFacts(JustO(DBlockfb))=mapSingleton(entryLabelb)fbodyFacts::LabelMap(DBlockfnCC)->FactBasefbodyFactsbody=mapFoldWithKeyfnoFactsbodywheref::foralltax.(NonLocalt)=>Label->DBlockatCx->LabelMapa->LabelMapaflbl(DBlockf_)fb=mapInsertlblffb--- implementation of the constructors (boring)dgnil=GNildgnilC=GManyNothingOemptyBodyNothingOdgSplice=splicefzCatwherefzCat::DBlockfneO->DBlocktnOx->DBlockfnexfzCat(DBlockfb1)(DBlock_b2)=DBlockf(b1`blockAppend`b2)------------------------------------------------------------------ Utilities------------------------------------------------------------------ Lifting based on shape:-- - from nodes to blocks-- - from facts to fact-like things-- Lowering back:-- - from fact-like things to facts-- Note that the latter two functions depend only on the entry shape.-- @ start node.texclassShapeLifterexwheresingletonDG::f->nex->DGfnexfwdEntryFact::NonLocaln=>nex->f->FacteffwdEntryLabel::NonLocaln=>nex->MaybeCe[Label]ftransfer::FwdTransfernf->nex->f->Factxffrewrite::FwdRewritemnf->nex->f->m(Maybe(Graphnex,FwdRewritemnf))-- @ end node.texbwdEntryFact::NonLocaln=>DataflowLatticef->nex->Factef->fbtransfer::BwdTransfernf->nex->Factxf->fbrewrite::BwdRewritemnf->nex->Factxf->m(Maybe(Graphnex,BwdRewritemnf))instanceShapeLifterCOwheresingletonDGfn=gUnitCO(DBlockf(BlockCOnBNil))fwdEntryFactnf=mapSingleton(entryLabeln)fbwdEntryFactlatnfb=getFactlat(entryLabeln)fbftransfer(FwdTransfer3(ft,_,_))nf=ftnfbtransfer(BwdTransfer3(bt,_,_))nf=btnffrewrite(FwdRewrite3(fr,_,_))nf=frnfbrewrite(BwdRewrite3(br,_,_))nf=brnffwdEntryLabeln=JustC[entryLabeln]instanceShapeLifterOOwheresingletonDGf=gUnitOO.DBlockf.BMiddlefwdEntryFact_f=fbwdEntryFact__f=fftransfer(FwdTransfer3(_,ft,_))nf=ftnfbtransfer(BwdTransfer3(_,bt,_))nf=btnffrewrite(FwdRewrite3(_,fr,_))nf=frnfbrewrite(BwdRewrite3(_,br,_))nf=brnffwdEntryLabel_=NothingCinstanceShapeLifterOCwheresingletonDGfn=gUnitOC(DBlockf(BlockOCBNiln))fwdEntryFact_f=fbwdEntryFact__f=fftransfer(FwdTransfer3(_,_,ft))nf=ftnfbtransfer(BwdTransfer3(_,_,bt))nf=btnffrewrite(FwdRewrite3(_,_,fr))nf=frnfbrewrite(BwdRewrite3(_,_,br))nf=brnffwdEntryLabel_=NothingC-- Fact lookup: the fact `orelse` bottomgetFact::DataflowLatticef->Label->FactBasef->fgetFactlatlfb=caselookupFactlfbofJustf->fNothing->fact_botlat{- Note [Respects fuel]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-}-- $fuel-- A value of type 'FwdRewrite' or 'BwdRewrite' /respects fuel/ if -- any function contained within the value satisfies the following properties:---- * When fuel is exhausted, it always returns 'Nothing'.---- * When it returns @Just g rw@, it consumes /exactly/ one unit-- of fuel, and new rewrite 'rw' also respects fuel.---- Provided that functions passed to 'mkFRewrite', 'mkFRewrite3', -- 'mkBRewrite', and 'mkBRewrite3' are not aware of the fuel supply,-- the results respect fuel.---- It is an /unchecked/ run-time error for the argument passed to 'wrapFR',-- 'wrapFR2', 'wrapBR', or 'warpBR2' to return a function that does not respect fuel.