{-# LANGUAGE BangPatterns #-}{-# LANGUAGE GADTs #-}{-# LANGUAGE MultiParamTypeClasses #-}{-# LANGUAGE RankNTypes #-}{-# LANGUAGE ScopedTypeVariables #-}{-# LANGUAGE TypeFamilies #-}{-# OPTIONS_GHC -fprof-auto-top #-}---- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,-- and Norman Ramsey---- Modifications copyright (c) The University of Glasgow 2012---- This module is a specialised and optimised version of-- Compiler.Hoopl.Dataflow in the hoopl package. In particular it is-- specialised to the UniqSM monad.--moduleHoopl.Dataflow(C ,O ,Block ,lastNode ,entryLabel ,foldNodesBwdOO ,foldRewriteNodesBwdOO ,DataflowLattice (..),OldFact (..),NewFact (..),JoinedFact (..),TransferFun ,RewriteFun ,Fact ,FactBase ,getFact ,mkFactBase ,analyzeCmmFwd ,analyzeCmmBwd ,rewriteCmmBwd ,changedIf ,joinOutFacts ,joinFacts )whereimportGhcPrelude importCmm importUniqSupply importData.ArrayimportData.MaybeimportData.IntSet(IntSet)importqualifiedData.IntSetasIntSetimportHoopl.Block importHoopl.Graph importHoopl.Collections importHoopl.Label typefamilyFact x f ::*typeinstanceFact C f =FactBase f typeinstanceFact O f =f newtypeOldFact a =OldFact a newtypeNewFact a =NewFact a -- | The result of joining OldFact and NewFact.dataJoinedFact a =Changed !a -- ^ Result is different than OldFact.|NotChanged !a -- ^ Result is the same as OldFact.getJoined::JoinedFact a ->a getJoined (Changed a )=a getJoined(NotChanged a )=a changedIf::Bool->a ->JoinedFact a changedIf True=Changed changedIfFalse=NotChanged typeJoinFun a =OldFact a ->NewFact a ->JoinedFact a dataDataflowLattice a =DataflowLattice {fact_bot ::a ,fact_join ::JoinFun a }dataDirection =Fwd |Bwd typeTransferFun f =CmmBlock ->FactBase f ->FactBase f -- | Function for rewrtiting and analysis combined. To be used with-- @rewriteCmm@.---- Currently set to work with @UniqSM@ monad, but we could probably abstract-- that away (if we do that, we might want to specialize the fixpoint algorithms-- to the particular monads through SPECIALIZE).typeRewriteFun f =CmmBlock ->FactBase f ->UniqSM (CmmBlock ,FactBase f )analyzeCmmBwd,analyzeCmmFwd::DataflowLattice f ->TransferFun f ->CmmGraph ->FactBase f ->FactBase f analyzeCmmBwd =analyzeCmm Bwd analyzeCmmFwd =analyzeCmm Fwd analyzeCmm::Direction ->DataflowLattice f ->TransferFun f ->CmmGraph ->FactBase f ->FactBase f analyzeCmm dir lattice transfer cmmGraph initFact =letentry =g_entrycmmGraph hooplGraph =g_graphcmmGraph blockMap =casehooplGraph ofGMany NothingO bm NothingO ->bm infixpointAnalysis dir lattice transfer entry blockMap initFact -- Fixpoint algorithm.fixpointAnalysis::forallf .Direction ->DataflowLattice f ->TransferFun f ->Label ->LabelMap CmmBlock ->FactBase f ->FactBase f fixpointAnalysis direction lattice do_block entry blockmap =loop start where-- Sorting the blocks helps to minimize the number of times we need to-- process blocks. For instance, for forward analysis we want to look at-- blocks in reverse postorder. Also, see comments for sortBlocks.blocks =sortBlocks direction entry blockmap num_blocks =lengthblocks block_arr ={-# SCC"block_arr"#-}listArray(0,num_blocks -1)blocks start ={-# SCC"start"#-}IntSet.fromDistinctAscList[0..num_blocks -1]dep_blocks ={-# SCC"dep_blocks"#-}mkDepBlocks direction blocks join =fact_joinlattice loop::IntHeap -- ^ Worklist, i.e., blocks to process->FactBase f -- ^ Current result (increases monotonically)->FactBase f loop todo !fbase1 |Just(index ,todo1 )<-IntSet.minViewtodo =letblock =block_arr !index out_facts ={-# SCC"do_block"#-}do_block block fbase1 -- For each of the outgoing edges, we join it with the current-- information in fbase1 and (if something changed) we update it-- and add the affected blocks to the worklist.(todo2 ,fbase2 )={-# SCC"mapFoldWithKey"#-}mapFoldlWithKey (updateFact join dep_blocks )(todo1 ,fbase1 )out_facts inloop todo2 fbase2 loop_!fbase1 =fbase1 rewriteCmmBwd::DataflowLattice f ->RewriteFun f ->CmmGraph ->FactBase f ->UniqSM (CmmGraph ,FactBase f )rewriteCmmBwd =rewriteCmm Bwd rewriteCmm::Direction ->DataflowLattice f ->RewriteFun f ->CmmGraph ->FactBase f ->UniqSM (CmmGraph ,FactBase f )rewriteCmm dir lattice rwFun cmmGraph initFact =doletentry =g_entrycmmGraph hooplGraph =g_graphcmmGraph blockMap1 =casehooplGraph ofGMany NothingO bm NothingO ->bm (blockMap2 ,facts )<-fixpointRewrite dir lattice rwFun entry blockMap1 initFact return(cmmGraph {g_graph=GMany NothingO blockMap2 NothingO },facts )fixpointRewrite::forallf .Direction ->DataflowLattice f ->RewriteFun f ->Label ->LabelMap CmmBlock ->FactBase f ->UniqSM (LabelMap CmmBlock ,FactBase f )fixpointRewrite dir lattice do_block entry blockmap =loop start blockmap where-- Sorting the blocks helps to minimize the number of times we need to-- process blocks. For instance, for forward analysis we want to look at-- blocks in reverse postorder. Also, see comments for sortBlocks.blocks =sortBlocks dir entry blockmap num_blocks =lengthblocks block_arr ={-# SCC"block_arr_rewrite"#-}listArray(0,num_blocks -1)blocks start ={-# SCC"start_rewrite"#-}IntSet.fromDistinctAscList[0..num_blocks -1]dep_blocks ={-# SCC"dep_blocks_rewrite"#-}mkDepBlocks dir blocks join =fact_joinlattice loop::IntHeap -- ^ Worklist, i.e., blocks to process->LabelMap CmmBlock -- ^ Rewritten blocks.->FactBase f -- ^ Current facts.->UniqSM (LabelMap CmmBlock ,FactBase f )loop todo !blocks1 !fbase1 |Just(index ,todo1 )<-IntSet.minViewtodo =do-- Note that we use the *original* block here. This is important.-- We're optimistically rewriting blocks even before reaching the fixed-- point, which means that the rewrite might be incorrect. So if the-- facts change, we need to rewrite the original block again (taking-- into account the new facts).letblock =block_arr !index (new_block ,out_facts )<-{-# SCC"do_block_rewrite"#-}do_block block fbase1 letblocks2 =mapInsert (entryLabel new_block )new_block blocks1 (todo2 ,fbase2 )={-# SCC"mapFoldWithKey_rewrite"#-}mapFoldlWithKey (updateFact join dep_blocks )(todo1 ,fbase1 )out_facts loop todo2 blocks2 fbase2 loop_!blocks1 !fbase1 =return(blocks1 ,fbase1 ){-
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* ixpoints. For the backward
 case we must treat every block as reachable; it might finish with a
 'return', and therefore have no successors, for example.
-}------------------------------------------------------------------------------- Pieces that are shared by fixpoint and fixpoint_anal------------------------------------------------------------------------------- | Sort the blocks into the right order for analysis. This means reverse-- postorder for a forward analysis. For the backward one, we simply reverse-- that (see Note [Backward vs forward analysis]).sortBlocks::NonLocal n =>Direction ->Label ->LabelMap (Block n C C )->[Block n C C ]sortBlocks direction entry blockmap =casedirection ofFwd ->fwd Bwd ->reversefwd wherefwd =revPostorderFrom blockmap entry -- Note [Backward vs forward analysis]---- 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 a-- backward analysis must also include reachable blocks that don't reach the-- exit, as in a procedure that loops forever and has side effects.)-- For instance, let E be the entry and X the exit blocks (arrows indicate-- control flow)-- E -> X-- E -> B-- B -> C-- C -> B-- We do need to include B and C even though they're unreachable in the-- *reverse* graph (that we could use for backward analysis):-- E <- X-- E <- B-- B <- C-- C <- B-- So when sorting the blocks for the backward analysis, we simply take the-- reverse of what is used for the forward one.-- | Construct a mapping from a @Label@ to the block indexes that should be-- re-analyzed if the facts at that @Label@ change.---- Note that we're considering here the entry point of the block, so if the-- facts change at the entry:-- * for a backward analysis we need to re-analyze all the predecessors, but-- * for a forward analysis, we only need to re-analyze the current block-- (and that will in turn propagate facts into its successors).mkDepBlocks::Direction ->[CmmBlock ]->LabelMap IntSetmkDepBlocks Fwd blocks =go blocks 0mapEmpty wherego []!_!dep_map =dep_map go(b :bs )!n !dep_map =go bs (n +1)$mapInsert (entryLabel b )(IntSet.singletonn )dep_map mkDepBlocksBwd blocks =go blocks 0mapEmpty wherego []!_!dep_map =dep_map go(b :bs )!n !dep_map =letinsert m l =mapInsertWith IntSet.unionl (IntSet.singletonn )m ingo bs (n +1)$foldl'insert dep_map (successors b )-- | After some new facts have been generated by analysing a block, we-- fold this function over them to generate (a) a list of block-- indices to (re-)analyse, and (b) the new FactBase.updateFact::JoinFun f ->LabelMap IntSet->(IntHeap ,FactBase f )->Label ->f -- out fact->(IntHeap ,FactBase f )updateFact fact_join dep_blocks (todo ,fbase )lbl new_fact =caselookupFact lbl fbase ofNothing->-- Note [No old fact]let!z =mapInsert lbl new_fact fbase in(changed ,z )Justold_fact ->casefact_join (OldFact old_fact )(NewFact new_fact )of(NotChanged _)->(todo ,fbase )(Changed f )->let!z =mapInsert lbl f fbase in(changed ,z )wherechanged =todo `IntSet.union`mapFindWithDefault IntSet.emptylbl dep_blocks {-
Note [No old fact]
We know that the new_fact is >= _|_, so we don't need to join. However,
if the new fact is also _|_, and we have already analysed its block,
we don't need to record a change. So there's a tradeoff here. It turns
out that always recording a change is faster.
-}------------------------------------------------------------------ Utilities------------------------------------------------------------------ Fact lookup: the fact `orelse` bottomgetFact::DataflowLattice f ->Label ->FactBase f ->f getFact lat l fb =caselookupFact l fb ofJustf ->f Nothing->fact_botlat -- | Returns the result of joining the facts from all the successors of the-- provided node or block.joinOutFacts::(NonLocal n )=>DataflowLattice f ->n e C ->FactBase f ->f joinOutFacts lattice nonLocal fact_base =foldl'join (fact_botlattice )facts wherejoin new old =getJoined $fact_joinlattice (OldFact old )(NewFact new )facts =[fromJustfact |s <-successors nonLocal ,letfact =lookupFact s fact_base ,isJustfact ]joinFacts::DataflowLattice f ->[f ]->f joinFacts lattice facts =foldl'join (fact_botlattice )facts wherejoin new old =getJoined $fact_joinlattice (OldFact old )(NewFact new )-- | Returns the joined facts for each label.mkFactBase::DataflowLattice f ->[(Label ,f )]->FactBase f mkFactBase lattice =foldl'add mapEmpty wherejoin =fact_joinlattice add result (l ,f1 )=let!newFact =casemapLookup l result ofNothing->f1 Justf2 ->getJoined $join (OldFact f1 )(NewFact f2 )inmapInsert l newFact result -- | Folds backward over all nodes of an open-open block.-- Strict in the accumulator.foldNodesBwdOO::(CmmNode O O ->f ->f )->Block CmmNode O O ->f ->f foldNodesBwdOO funOO =go wherego (BCat b1 b2 )f =go b1 $!go b2 f go(BSnoc h n )f =go h $!funOO n f go(BCons n t )f =funOO n $!go t f go(BMiddle n )f =funOO n f goBNil f =f {-# INLINABLEfoldNodesBwdOO#-}-- | Folds backward over all the nodes of an open-open block and allows-- rewriting them. The accumulator is both the block of nodes and @f@ (usually-- dataflow facts).-- Strict in both accumulated parts.foldRewriteNodesBwdOO::forallf .(CmmNode O O ->f ->UniqSM (Block CmmNode O O ,f ))->Block CmmNode O O ->f ->UniqSM (Block CmmNode O O ,f )foldRewriteNodesBwdOO rewriteOO initBlock initFacts =go initBlock initFacts wherego (BCons node1 block1 )!fact1 =(rewriteOO node1 `comp `go block1 )fact1 go(BSnoc block1 node1 )!fact1 =(go block1 `comp `rewriteOO node1 )fact1 go(BCat blockA1 blockB1 )!fact1 =(go blockA1 `comp `go blockB1 )fact1 go(BMiddle node )!fact1 =rewriteOO node fact1 goBNil !fact =return(BNil ,fact )comp rew1 rew2 =\f1 ->do(b ,f2 )<-rew2 f1 (a ,!f3 )<-rew1 f2 let!c =joinBlocksOO a b return(c ,f3 ){-# INLINEcomp#-}{-# INLINABLEfoldRewriteNodesBwdOO#-}joinBlocksOO::Block n O O ->Block n O O ->Block n O O joinBlocksOO BNil b =b joinBlocksOOb BNil =b joinBlocksOO(BMiddle n )b =blockCons n b joinBlocksOOb (BMiddle n )=blockSnoc b n joinBlocksOOb1 b2 =BCat b1 b2 typeIntHeap =IntSet