hoopl (empty) → 3.7.0.0
raw patch · 10 files changed
+1005/−0 lines, 10 filesdep +basedep +containerssetup-changed
Dependencies added: base, containers
Files
- Compiler/Hoopl.hs +14/−0
- Compiler/Hoopl/Dataflow.hs +493/−0
- Compiler/Hoopl/Fuel.hs +40/−0
- Compiler/Hoopl/Graph.hs +62/−0
- Compiler/Hoopl/GraphUtil.hs +63/−0
- Compiler/Hoopl/Label.hs +98/−0
- Compiler/Hoopl/MkGraph.hs +181/−0
- LICENSE +33/−0
- Setup.hs +2/−0
- hoopl.cabal +19/−0
+ Compiler/Hoopl.hs view
@@ -0,0 +1,14 @@+module Compiler.Hoopl+ ( module Compiler.Hoopl.Dataflow+ , module Compiler.Hoopl.Fuel+ , module Compiler.Hoopl.Graph+ , module Compiler.Hoopl.Label+ , module Compiler.Hoopl.MkGraph+ )+where++import Compiler.Hoopl.Dataflow+import Compiler.Hoopl.Fuel+import Compiler.Hoopl.Graph+import Compiler.Hoopl.Label hiding (allLabels)+import Compiler.Hoopl.MkGraph
+ Compiler/Hoopl/Dataflow.hs view
@@ -0,0 +1,493 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- bug in GHC++{- Notes about the genesis of Hoopl7+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Hoopl7 has the following major chages++a) GMany has symmetric entry and exit+b) GMany closed-entry does not record a BlockId+c) GMany open-exit does not record a BlockId+d) The body of a GMany is called Body+e) A Body is just a list of blocks, not a map. I've argued+ elsewhere that this is consistent with (c)++A consequence is that Graph is no longer an instance of Edges,+but nevertheless I managed to keep the ARF and ARB signatures+nice and uniform.++This was made possible by++* ForwardTransfer looks like this:+ type ForwardTransfer n f+ = forall e x. n e x -> Fact e f -> Fact x f + type family Fact x f :: *+ type instance Fact C f = FactBase f+ type instance Fact O f = f++ Note that the incoming fact is a Fact (not just 'f' as in Hoopl5,6).+ It's up to the *transfer function* to look up the appropriate fact+ in the FactBase for a closed-entry node. Example:+ constProp (Label l) fb = lookupFact fb l+ That is how Hoopl can avoid having to know the block-id for the+ first node: it defers to the client.++ [Side note: that means the client must know about + bottom, in case the looupFact returns Nothing]++* Note also that ForwardTransfer *returns* a Fact too;+ that is, the types in both directions are symmetrical.+ Previously we returned a [(BlockId,f)] but I could not see+ how to make everything line up if we do this.++ Indeed, the main shortcoming of Hoopl7 is that we are more+ or less forced into this uniform representation of the facts+ flowing into or out of a closed node/block/graph, whereas+ previously we had more flexibility.++ In exchange the code is neater, with fewer distinct types.+ And morally a FactBase is equivalent to [(BlockId,f)] and+ nearly equivalent to (BlockId -> f).++* I've realised that forwardBlockList and backwardBlockList+ both need (Edges n), and that goes everywhere.++* I renamed BlockId to Label+-}++module Compiler.Hoopl.Dataflow + ( DataflowLattice(..)+ , ChangeFlag(..)+ , ForwardPass(..), FwdTransfer, FwdRewrite, SimpleFwdRewrite+ , noFwdRewrite, thenFwdRw, shallowFwdRw, deepFwdRw+ , BackwardPass(..), BwdTransfer, BwdRewrite, SimpleBwdRewrite+ , noBwdRewrite, thenBwdRw, shallowBwdRw, deepBwdRw+ , Fact+ , analyzeAndRewriteFwd, analyzeAndRewriteBwd+ )+where++import Compiler.Hoopl.Fuel+import Compiler.Hoopl.Graph+import qualified Compiler.Hoopl.GraphUtil as U+import Compiler.Hoopl.Label+import Compiler.Hoopl.MkGraph (AGraph)+++-----------------------------------------------------------------------------+-- DataflowLattice+-----------------------------------------------------------------------------++data DataflowLattice a = DataflowLattice { + fact_name :: String, -- Documentation+ fact_bot :: a, -- Lattice bottom element+ fact_extend :: a -> a -> (ChangeFlag,a), -- Lattice join plus change flag+ fact_do_logging :: Bool -- log changes+}++data ChangeFlag = NoChange | SomeChange++-----------------------------------------------------------------------------+-- Analyze and rewrite forward: the interface+-----------------------------------------------------------------------------++data ForwardPass n f+ = FwdPass { fp_lattice :: DataflowLattice f+ , fp_transfer :: FwdTransfer n f+ , fp_rewrite :: FwdRewrite n f }++type FwdTransfer n f + = forall e x. n e x -> Fact e f -> Fact x f ++type FwdRewrite n f + = forall e x. n e x -> Fact e f -> Maybe (FwdRes n f e x)+data FwdRes n f e x = FwdRes (AGraph n e x) (FwdRewrite n f)+ -- result of a rewrite is a new graph and a (possibly) new rewrite function++type family Fact x f :: *+type instance Fact C f = FactBase f+type instance Fact O f = f++type SimpleFwdRewrite n f + = forall e x. n e x -> Fact e f+ -> Maybe (AGraph n e x)++noFwdRewrite :: FwdRewrite n f+noFwdRewrite _ _ = Nothing++shallowFwdRw :: SimpleFwdRewrite n f -> FwdRewrite n f+shallowFwdRw rw n f = case (rw n f) of+ Nothing -> Nothing+ Just ag -> Just (FwdRes ag noFwdRewrite)++thenFwdRw :: FwdRewrite n f -> FwdRewrite n f -> FwdRewrite n f+thenFwdRw rw1 rw2 n f+ = case rw1 n f of+ Nothing -> rw2 n f+ Just (FwdRes ag rw1a) -> Just (FwdRes ag (rw1a `thenFwdRw` rw2))++deepFwdRw :: FwdRewrite n f -> FwdRewrite n f+deepFwdRw rw = rw `thenFwdRw` deepFwdRw rw++analyzeAndRewriteFwd+ :: forall n f. Edges n+ => ForwardPass n f+ -> Body n -> FactBase f+ -> FuelMonad (Body n, FactBase f)++analyzeAndRewriteFwd pass body facts+ = do { (rg, _) <- arfBody pass body facts+ ; return (normaliseBody rg) }++----------------------------------------------------------------+-- Forward Implementation+----------------------------------------------------------------+++type ARF thing n + = forall f e x. ForwardPass n f -> thing e x + -> Fact e f -> FuelMonad (RG n f e x, Fact x f)++arfNode :: Edges n => ARF n n+arfNode pass node f+ = do { mb_g <- withFuel (fp_rewrite pass node f)+ ; case mb_g of+ Nothing -> return (RGUnit f (BUnit node),+ fp_transfer pass node f)+ Just (FwdRes ag rw) -> do { g <- graphOfAGraph ag+ ; let pass' = pass { fp_rewrite = rw }+ ; arfGraph pass' g f } }++arfBlock :: Edges n => ARF (Block n) n+-- Lift from nodes to blocks+arfBlock pass (BUnit node) f = arfNode pass node f+arfBlock pass (BCat hd mids) f = do { (g1,f1) <- arfBlock pass hd f + ; (g2,f2) <- arfBlock pass mids f1 + ; return (g1 `RGCatO` g2, f2) }++arfBody :: Edges n+ => ForwardPass n f -> Body n -> FactBase f+ -> FuelMonad (RG n f C C, FactBase f)+ -- Outgoing factbase is restricted to Labels *not* in+ -- in the Body; the facts for Labels+ -- *in* the Body are in the BodyWithFacts+arfBody pass blocks init_fbase+ = fixpoint True (fp_lattice pass) (arfBlock pass) init_fbase $+ forwardBlockList (factBaseLabels init_fbase) blocks++arfGraph :: Edges n => ARF (Graph n) n+-- Lift from blocks to graphs+arfGraph _ GNil f = return (RGNil, f)+arfGraph pass (GUnit blk) f = arfBlock pass blk f+arfGraph pass (GMany NothingO body NothingO) f+ = do { (body', fb) <- arfBody pass body f+ ; return (body', fb) }+arfGraph pass (GMany NothingO body (JustO exit)) f+ = do { (body', fb) <- arfBody pass body f+ ; (exit', fx) <- arfBlock pass exit fb+ ; return (body' `RGCatC` exit', fx) }+arfGraph pass (GMany (JustO entry) body NothingO) f+ = do { (entry', fe) <- arfBlock pass entry f+ ; (body', fb) <- arfBody pass body fe+ ; return (entry' `RGCatC` body', fb) }+arfGraph pass (GMany (JustO entry) body (JustO exit)) f+ = do { (entry', fe) <- arfBlock pass entry f+ ; (body', fb) <- arfBody pass body fe+ ; (exit', fx) <- arfBlock pass exit fb+ ; return (entry' `RGCatC` body' `RGCatC` exit', fx) }++forwardBlockList :: Edges n => [Label] -> Body n -> [(Label,Block n C C)]+-- This produces a list of blocks in order suitable for forward analysis.+-- ToDo: Do a topological sort to improve convergence rate of fixpoint+-- This will require a (HavingSuccessors l) class constraint+forwardBlockList _ blks = bodyList blks++-----------------------------------------------------------------------------+-- Backward analysis and rewriting: the interface+-----------------------------------------------------------------------------++data BackwardPass n f+ = BwdPass { bp_lattice :: DataflowLattice f+ , bp_transfer :: BwdTransfer n f+ , bp_rewrite :: BwdRewrite n f }++type BwdTransfer n f + = forall e x. n e x -> Fact x f -> Fact e f +type BwdRewrite n f + = forall e x. n e x -> Fact x f -> Maybe (BwdRes n f e x)+data BwdRes n f e x = BwdRes (AGraph n e x) (BwdRewrite n f)++type SimpleBwdRewrite n f + = forall e x. n e x -> Fact x f+ -> Maybe (AGraph n e x)++noBwdRewrite :: BwdRewrite n f+noBwdRewrite _ _ = Nothing++shallowBwdRw :: SimpleBwdRewrite n f -> BwdRewrite n f+shallowBwdRw rw n f = case (rw n f) of+ Nothing -> Nothing+ Just ag -> Just (BwdRes ag noBwdRewrite)++thenBwdRw :: BwdRewrite n f -> BwdRewrite n f -> BwdRewrite n f+thenBwdRw rw1 rw2 n f+ = case rw1 n f of+ Nothing -> rw2 n f+ Just (BwdRes ag rw1a) -> Just (BwdRes ag (rw1a `thenBwdRw` rw2))++deepBwdRw :: BwdRewrite n f -> BwdRewrite n f+deepBwdRw rw = rw `thenBwdRw` deepBwdRw rw+++-----------------------------------------------------------------------------+-- Backward implementation+-----------------------------------------------------------------------------++type ARB thing n + = forall f e x. BackwardPass n f -> thing e x+ -> Fact x f -> FuelMonad (RG n f e x, Fact e f)++arbNode :: Edges n => ARB n n+-- Lifts (BwdTransfer,BwdRewrite) to ARB_Node; +-- this time we do rewriting as well. +-- The ARB_Graph parameters specifies what to do with the rewritten graph+arbNode pass node f+ = do { mb_g <- withFuel (bp_rewrite pass node f)+ ; case mb_g of+ Nothing -> return (RGUnit entry_f (BUnit node), entry_f)+ where+ entry_f = bp_transfer pass node f+ Just (BwdRes ag rw) -> do { g <- graphOfAGraph ag+ ; let pass' = pass { bp_rewrite = rw }+ ; arbGraph pass' g f} }++arbBlock :: Edges n => ARB (Block n) n +-- Lift from nodes to blocks+arbBlock pass (BUnit node) f = arbNode pass node f+arbBlock pass (BCat b1 b2) f = do { (g2,f2) <- arbBlock pass b2 f+ ; (g1,f1) <- arbBlock pass b1 f2+ ; return (g1 `RGCatO` g2, f1) }++arbBody :: Edges n+ => BackwardPass n f -> Body n -> FactBase f+ -> FuelMonad (RG n f C C, FactBase f)+arbBody pass blocks init_fbase+ = fixpoint False (bp_lattice pass) (arbBlock pass) init_fbase $+ backwardBlockList (factBaseLabels init_fbase) blocks ++arbGraph :: Edges n => ARB (Graph n) n+arbGraph _ GNil f = return (RGNil, f)+arbGraph pass (GUnit blk) f = arbBlock pass blk f+arbGraph pass (GMany NothingO body NothingO) f+ = do { (body', fb) <- arbBody pass body f+ ; return (body', fb) }+arbGraph pass (GMany NothingO body (JustO exit)) f+ = do { (exit', fx) <- arbBlock pass exit f+ ; (body', fb) <- arbBody pass body fx+ ; return (body' `RGCatC` exit', fb) }+arbGraph pass (GMany (JustO entry) body NothingO) f+ = do { (body', fb) <- arbBody pass body f+ ; (entry', fe) <- arbBlock pass entry fb+ ; return (entry' `RGCatC` body', fe) }+arbGraph pass (GMany (JustO entry) body (JustO exit)) f+ = do { (exit', fx) <- arbBlock pass exit f+ ; (body', fb) <- arbBody pass body fx+ ; (entry', fe) <- arbBlock pass entry fb+ ; return (entry' `RGCatC` body' `RGCatC` exit', fe) }++backwardBlockList :: Edges n => [Label] -> Body n -> [(Label,Block n C C)]+-- This produces a list of blocks in order suitable for backward analysis.+backwardBlockList _ blks = bodyList blks++analyzeAndRewriteBwd+ :: forall n f. Edges n+ => BackwardPass n f + -> Body n -> FactBase f + -> FuelMonad (Body n, FactBase f)++analyzeAndRewriteBwd pass body facts+ = do { (rg, _) <- arbBody pass body facts+ ; return (normaliseBody rg) }+++-----------------------------------------------------------------------------+-- fixpoint: finding fixed points+-----------------------------------------------------------------------------++data TxFactBase n f+ = TxFB { tfb_fbase :: FactBase f+ , tfb_rg :: RG n f C C -- Transformed blocks+ , tfb_cha :: ChangeFlag+ , tfb_lbls :: LabelSet }+ -- Note [TxFactBase change flag]+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ -- Set the tfb_cha flag iff + -- (a) the fact in tfb_fbase for or a block L changes+ -- (b) L is in tfb_lbls.+ -- The tfb_lbls are all Labels of the *original* + -- (not transformed) blocks++updateFact :: DataflowLattice f -> LabelSet -> (Label, f)+ -> (ChangeFlag, FactBase f) + -> (ChangeFlag, FactBase f)+-- See Note [TxFactBase change flag]+updateFact lat lbls (lbl, new_fact) (cha, fbase)+ | NoChange <- cha2 = (cha, fbase)+ | lbl `elemLabelSet` lbls = (SomeChange, new_fbase)+ | otherwise = (cha, new_fbase)+ where+ (cha2, res_fact) + = case lookupFact fbase lbl of+ Nothing -> (SomeChange, new_fact) -- Note [Unreachable blocks]+ Just old_fact -> fact_extend lat old_fact new_fact+ new_fbase = extendFactBase fbase lbl res_fact++fixpoint :: forall n f. Edges n+ => Bool -- Going forwards?+ -> DataflowLattice f+ -> (Block n C C -> FactBase f+ -> FuelMonad (RG n f C C, FactBase f))+ -> FactBase f -> [(Label, Block n C C)]+ -> FuelMonad (RG n f C C, FactBase f)+fixpoint is_fwd lat do_block init_fbase blocks+ = do { fuel <- getFuel + ; tx_fb <- loop fuel init_fbase+ ; return (tfb_rg tx_fb, + tfb_fbase tx_fb `delFromFactBase` blocks) }+ -- The successors of the Graph are the the Labels for which+ -- we have facts, that are *not* in the blocks of the graph+ where+ tx_blocks :: [(Label, Block n C C)] + -> TxFactBase n f -> FuelMonad (TxFactBase n f)+ tx_blocks [] tx_fb = return tx_fb+ tx_blocks ((lbl,blk):bs) tx_fb = tx_block lbl blk tx_fb >>= tx_blocks bs++ tx_block :: Label -> Block n C C + -> TxFactBase n f -> FuelMonad (TxFactBase n f)+ tx_block lbl blk tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls+ , tfb_rg = blks, tfb_cha = cha })+ | is_fwd && not (lbl `elemFactBase` fbase)+ = return tx_fb -- Note [Unreachable blocks]+ | otherwise+ = do { (rg, out_facts) <- do_block blk fbase+ ; let (cha',fbase') + = foldr (updateFact lat lbls) (cha,fbase) + (factBaseList out_facts)+ ; return (TxFB { tfb_lbls = extendLabelSet lbls lbl+ , tfb_rg = rg `RGCatC` blks+ , tfb_fbase = fbase', tfb_cha = cha' }) }++ loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f)+ loop fuel fbase + = do { let init_tx_fb = TxFB { tfb_fbase = fbase+ , tfb_cha = NoChange+ , tfb_rg = RGNil+ , tfb_lbls = emptyLabelSet }+ ; tx_fb <- tx_blocks blocks init_tx_fb+ ; case tfb_cha tx_fb of+ NoChange -> return tx_fb+ SomeChange -> do { setFuel fuel+ ; loop fuel (tfb_fbase tx_fb) } }++{- 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++* 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.+-}++-----------------------------------------------------------------------------+-- RG: an internal data type for graphs under construction+-- TOTALLY internal to Hoopl+-----------------------------------------------------------------------------++data RG n f e x where+ RGNil :: RG n f a a+ RGUnit :: Fact e f -> Block n e x -> RG n f e x+ RGCatO :: RG n f e O -> RG n f O x -> RG n f e x+ RGCatC :: RG n f e C -> RG n f C x -> RG n f e x++type BodyWithFacts n f = (Body n, FactBase f)+type GraphWithFacts n f e x = (Graph n e x, FactBase f)+ -- A Graph together with the facts for that graph+ -- The domains of the two maps should be identical++normaliseBody :: Edges n => RG n f C C -> BodyWithFacts n f+normaliseBody rg = (body, fact_base)+ where+ (GMany _ body _, fact_base) = normCC rg++normOO :: Edges n => RG n f O O -> GraphWithFacts n f O O+normOO RGNil = (GNil, noFacts)+normOO (RGUnit _ b) = (GUnit b, noFacts)+normOO (RGCatO g1 g2) = normOO g1 `gwfCat` normOO g2+normOO (RGCatC g1 g2) = normOC g1 `gwfCat` normCO g2++normOC :: Edges n => RG n f O C -> GraphWithFacts n f O C+normOC (RGUnit _ b) = (GMany (JustO b) BodyEmpty NothingO, noFacts)+normOC (RGCatO g1 g2) = normOO g1 `gwfCat` normOC g2+normOC (RGCatC g1 g2) = normOC g1 `gwfCat` normCC g2++normCO :: Edges n => RG n f C O -> GraphWithFacts n f C O+normCO (RGUnit f b) = (GMany NothingO BodyEmpty (JustO b), unitFact l f)+ where+ l = entryLabel b+normCO (RGCatO g1 g2) = normCO g1 `gwfCat` normOO g2+normCO (RGCatC g1 g2) = normCC g1 `gwfCat` normCO g2++normCC :: Edges n => RG n f C C -> GraphWithFacts n f C C+normCC RGNil = (GMany NothingO BodyEmpty NothingO, noFacts)+normCC (RGUnit f b) = (GMany NothingO (BodyUnit b) NothingO, unitFact l f)+ where+ l = entryLabel b+normCC (RGCatO g1 g2) = normCO g1 `gwfCat` normOC g2+normCC (RGCatC g1 g2) = normCC g1 `gwfCat` normCC g2++gwfCat :: Edges n => GraphWithFacts n f e a+ -> GraphWithFacts n f a x + -> GraphWithFacts n f e x+gwfCat (g1, fb1) (g2, fb2) = (g1 `gCat` g2, fb1 `unionFactBase` fb2)++{-+bwfUnion :: BodyWithFacts n f -> BodyWithFacts n f -> BodyWithFacts n f+bwfUnion (bg1, fb1) (bg2, fb2) = (bg1 `BodyCat` bg2, fb1 `unionFactBase` fb2)+-}++-----------------------------------------------------------------------------++graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x)+graphOfAGraph ag = ag+++gCat :: Graph n e a -> Graph n a x -> Graph n e x+gCat = U.gCatAny++{- Not sure why the following does not work! ---NR+gCat g@(GMany _ _ NothingO) g' = U.gCatClosed g g'+gCat g g'@(GMany NothingO _ _) = U.gCatClosed g g'+gCat g g' = U.gCat g g'+-}+
+ Compiler/Hoopl/Fuel.hs view
@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+-- The fuel monad+-----------------------------------------------------------------------------++module Compiler.Hoopl.Fuel+ ( Fuel+ , FuelMonad, withFuel, getFuel, setFuel+ , freshLabel+ + , runWithFuel+ )+where++import Compiler.Hoopl.Label++type Fuel = Int++newtype FuelMonad a = FM { unFM :: Fuel -> [Label] -> (a, Fuel, [Label]) }++instance Monad FuelMonad where+ return x = FM (\f u -> (x,f,u))+ m >>= k = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')++withFuel :: Maybe a -> FuelMonad (Maybe a)+withFuel Nothing = return Nothing+withFuel (Just r) = FM (\f u -> if f==0 then (Nothing, f, u)+ else (Just r, f-1, u))++getFuel :: FuelMonad Fuel+getFuel = FM (\f u -> (f,f,u))++setFuel :: Fuel -> FuelMonad ()+setFuel f = FM (\_ u -> ((), f, u))++runWithFuel :: Fuel -> FuelMonad a -> a+runWithFuel fuel m = a+ where (a, _, _) = unFM m fuel allLabels++freshLabel :: FuelMonad Label+freshLabel = FM (\f (l:ls) -> (l, f, ls))
+ Compiler/Hoopl/Graph.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE GADTs, EmptyDataDecls #-}++module Compiler.Hoopl.Graph + ( O, C, Block(..), Body(..), Graph(..), MaybeO(..)+ , Edges, entryLabel, successors+ , addBlock, bodyList+ )+where++import Compiler.Hoopl.Label++-----------------------------------------------------------------------------+-- Graphs+-----------------------------------------------------------------------------++data O+data C++-- Blocks are always non-empty+data Block n e x where+ BUnit :: n e x -> Block n e x+ BCat :: Block n e O -> Block n O x -> Block n e x++data Body n where+ BodyEmpty :: Body n+ BodyUnit :: Block n C C -> Body n+ BodyCat :: Body n -> Body n -> Body n++data Graph n e x where+ GNil :: Graph n O O+ GUnit :: Block n O O -> Graph n O O+ GMany :: MaybeO e (Block n O C) + -> Body n+ -> MaybeO x (Block n C O)+ -> Graph n e x++data MaybeO ex t where+ JustO :: t -> MaybeO O t+ NothingO :: MaybeO C t++-------------------------------+class Edges thing where+ entryLabel :: thing C x -> Label+ successors :: thing e C -> [Label]++instance Edges n => Edges (Block n) where+ entryLabel (BUnit n) = entryLabel n+ entryLabel (b `BCat` _) = entryLabel b+ successors (BUnit n) = successors n+ successors (BCat _ b) = successors b++------------------------------+addBlock :: Block n C C -> Body n -> Body n+addBlock b body = BodyUnit b `BodyCat` body++bodyList :: Edges n => Body n -> [(Label,Block n C C)]+bodyList body = go body []+ where+ go BodyEmpty bs = bs+ go (BodyUnit b) bs = (entryLabel b, b) : bs+ go (BodyCat b1 b2) bs = go b1 (go b2 bs)+
+ Compiler/Hoopl/GraphUtil.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- bug in GHC++-- N.B. addBasicBlocks won't work on OO without a Node (branch/label) constraint++module Compiler.Hoopl.GraphUtil+ ( gCat, addEntrySeq, addExitSeq -- , addBasicBlocks+ , gCatClosed+ , gCatAny+ , bodyGraph+ )++where++import Compiler.Hoopl.Graph++bodyGraph :: Body n -> Graph n C C+bodyGraph b = GMany NothingO b NothingO+++gCatAny :: Graph n e a -> Graph n a x -> Graph n e x+gCat :: Graph n e O -> Graph n O x -> Graph n e x+addEntrySeq :: Graph n O C -> Graph n C x -> Graph n O x+addExitSeq :: Graph n e C -> Graph n C O -> Graph n e O+--addBasicBlocks :: Graph n e x -> Graph n C C -> Graph n e x+gCatClosed :: Graph n e C -> Graph n C x -> Graph n e x++gCatAny GNil g2 = g2+gCatAny g1 GNil = g1++gCatAny (GUnit b1) (GUnit b2) + = GUnit (b1 `BCat` b2)++gCatAny (GUnit b) (GMany (JustO e) bs x) + = GMany (JustO (b `BCat` e)) bs x++gCatAny (GMany e bs (JustO x)) (GUnit b2) + = GMany e bs (JustO (x `BCat` b2))++gCatAny (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) bs2 x2)+ = GMany e1 (addBlock (x1 `BCat` e2) bs1 `BodyCat` bs2) x2++gCatAny (GMany e1 bs1 NothingO) (GMany NothingO bs2 x2)+ = GMany e1 (bs1 `BodyCat` bs2) x2++gCat = gCatAny+addEntrySeq = gCatAny+addExitSeq = gCatAny+gCatClosed = gCatAny++{-+addEntrySeq (GMany entry body NothingO) (GMany NothingO body' exit) + = GMany entry (body `BodyCat` body') exit+ +addExitSeq (GMany entry body NothingO) (GMany NothingO body' exit) + = GMany entry (body `BodyCat` body') exit+ +--addBasicBlocks GNil g2 = g2+++gCatClosed (GMany e1 bs1 NothingO) (GMany NothingO bs2 x2)+ = GMany e1 (bs1 `BodyCat` bs2) x2+-}
+ Compiler/Hoopl/Label.hs view
@@ -0,0 +1,98 @@+module Compiler.Hoopl.Label+ ( Label+ , allLabels -- to be used only by the Fuel monad+ , LabelMap+ , FactBase, noFacts, mkFactBase, unitFact, lookupFact, extendFactBase+ , delFromFactBase, unionFactBase+ , elemFactBase, factBaseLabels, factBaseList+ , LabelSet, emptyLabelSet, extendLabelSet, mkLabelSet, elemLabelSet, labelSetElems+ , minusLabelSet, unionLabelSet+ )++where++import qualified Data.IntMap as M+import qualified Data.IntSet as S++newtype Label = Label { unLabel :: Int }+ deriving (Eq, Ord)++instance Show Label where+ show (Label n) = "L" ++ show n+++allLabels :: [Label]+allLabels = map Label [1..]++type LabelMap a = M.IntMap a++++-----------------------------------------------------------------------------+-- Label, FactBase, LabelSet+-----------------------------------------------------------------------------+++----------------------+type FactBase a = M.IntMap a++mapFst :: (a->b) -> (a, c) -> (b, c)+mapFst f (a, c) = (f a, c)++noFacts :: FactBase f+noFacts = M.empty++mkFactBase :: [(Label, f)] -> FactBase f+mkFactBase prs = M.fromList $ map (mapFst unLabel) prs++unitFact :: Label -> FactBase f -> FactBase f+-- Restrict a fact base to a single fact+unitFact (Label l) fb = case M.lookup l fb of+ Just f -> M.singleton l f+ Nothing -> M.empty++lookupFact :: FactBase f -> Label -> Maybe f+lookupFact env (Label blk_id) = M.lookup blk_id env++extendFactBase :: FactBase f -> Label -> f -> FactBase f+extendFactBase env (Label blk_id) f = M.insert blk_id f env++unionFactBase :: FactBase f -> FactBase f -> FactBase f+unionFactBase = M.union++elemFactBase :: Label -> FactBase f -> Bool+elemFactBase (Label l) = M.member l++factBaseLabels :: FactBase f -> [Label]+factBaseLabels = map Label . M.keys++factBaseList :: FactBase f -> [(Label, f)]+factBaseList = map (mapFst Label) . M.toList ++delFromFactBase :: FactBase f -> [(Label,a)] -> FactBase f+delFromFactBase fb blks = foldr (M.delete . unLabel . fst) fb blks++----------------------+type LabelSet = S.IntSet++emptyLabelSet :: LabelSet+emptyLabelSet = S.empty++extendLabelSet :: LabelSet -> Label -> LabelSet+extendLabelSet lbls (Label bid) = S.insert bid lbls++elemLabelSet :: Label -> LabelSet -> Bool+elemLabelSet (Label bid) lbls = S.member bid lbls++labelSetElems :: LabelSet -> [Label]+labelSetElems = map Label . S.toList++minusLabelSet :: LabelSet -> LabelSet -> LabelSet+minusLabelSet = S.difference++unionLabelSet :: LabelSet -> LabelSet -> LabelSet+unionLabelSet = S.union++mkLabelSet :: [Label] -> LabelSet+mkLabelSet = S.fromList . map unLabel+
+ Compiler/Hoopl/MkGraph.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Compiler.Hoopl.MkGraph+ ( AGraph, (<*>)+ , emptyAGraph, withFreshLabels+ , mkMiddle, mkMiddles, mkLast, mkEntry, mkBranch, mkLabel, mkIfThenElse, mkWhileDo+ , addEntrySeq, addExitSeq, catAGraphs+ , IfThenElseable+ )+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)++type AGraph n e x = FuelMonad (Graph n e x)++infixr 3 <*>+(<*>) :: AGraph n e O -> AGraph n O x -> AGraph n e x++class Labels l where+ withFreshLabels :: (l -> AGraph n e x) -> AGraph n e x++emptyAGraph :: AGraph n O O+emptyAGraph = return GNil++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+gCatClosed :: AGraph n e C -> AGraph n C x -> AGraph n e x++addEntrySeq = liftM2 U.addEntrySeq+addExitSeq = liftM2 U.addExitSeq+gCatClosed = liftM2 U.gCatClosed++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 :: (Node n) => Label -> AGraph n C O -- graph contains the label++-- below for convenience+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 => Node n where+ mkBranchNode :: Label -> n O C+ mkLabelNode :: Label -> n C O++mkBranch :: (Node n) => Label -> AGraph n O C++class IfThenElseable x where+ mkIfThenElse :: Node 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+{-+ fallThroughTo :: Node n+ => Label -> AGraph n e x -> AGraph n e C+-}++mkWhileDo :: (Node n)+ => (Label -> Label -> AGraph n O C) -- loop condition+ -> AGraph n O O -- body of the bloop+ -> AGraph n O O -- the final while loop++-- ================================================================+-- IMPLEMENTATION+-- ================================================================++(<*>) = liftM2 U.gCat ++catAGraphs :: [AGraph n O O] -> AGraph n O O+catAGraphs = foldr (<*>) emptyAGraph++-------------------------------------+-- constructors++mkLabel id = mkFirst $ mkLabelNode id+mkBranch target = mkLast $ mkBranchNode target+mkMiddles ms = foldr (<*>) (return GNil) (map mkMiddle ms)+++{-+outOfLine (AGraph g :: AGraph n C C) = AGraph g'+ where g' :: UniqSM (Graph n O O)+ g' = do zgraph <- g+ case zgraph of+ GF (Z.ZE_C _) _ Z.ZX_C ->+ do id <- freshLabel "outOfLine"+ return $ Z.mkLast (mkBranchNode id) <**> zgraph <**>+ Z.mkLabel id+ _ -> panic "tried to outOfLine a graph open at one or both ends"+-}++instance IfThenElseable O where+ mkIfThenElse cbranch tbranch fbranch = do+ endif <- freshLabel+ ltrue <- freshLabel+ lfalse <- freshLabel+ cbranch ltrue lfalse `addEntrySeq`+ (mkLabel ltrue <*> tbranch <*> mkBranch endif) `gCatClosed`+ (mkLabel lfalse <*> fbranch <*> mkBranch endif) `gCatClosed`+ mkLabel endif++{-+ fallThroughTo id g = g <*> mkBranch id+-}++instance IfThenElseable C where+ mkIfThenElse cbranch tbranch fbranch = do+ ltrue <- freshLabel+ lfalse <- freshLabel+ cbranch ltrue lfalse `gCatClosed`+ mkLabel ltrue <*> tbranch `gCatClosed`+ mkLabel lfalse <*> fbranch+{-+ fallThroughTo _ g = g+-}++mkWhileDo cbranch body = do+ test <- freshLabel+ head <- freshLabel+ endwhile <- freshLabel+ -- Forrest Baskett's while-loop layout+ mkBranch test `gCatClosed`+ mkLabel head <*> body <*> mkBranch test `gCatClosed`+ mkLabel test <*> cbranch head endwhile `gCatClosed`+ mkLabel endwhile++-------------------------------------+-- Debugging++{-+pprAGraph :: (Outputable m, LastNode l, Outputable l) => AGraph n e x -> UniqSM SDoc+pprAGraph g = graphOfAGraph g >>= return . ppr+-}++{-+Note [Branch follows branch]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Why do we say it's ok for a Branch to follow a Branch?+Because the standard constructor mkLabel-- has fall-through+semantics. So if you do a mkLabel, you finish the current block,+giving it a label, and start a new one that branches to that label.+Emitting a Branch at this point is fine: + goto L1; L2: ...stuff... +-}+++instance Labels Label where+ withFreshLabels f = freshLabel >>= 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 = return $ GMany NothingO BodyEmpty (JustO block)+mkEntry block = return $ GMany (JustO block) BodyEmpty NothingO++mkFirst = mkExit . BUnit+mkLast = mkEntry . BUnit+mkMiddle = return . GUnit . BUnit
+ LICENSE view
@@ -0,0 +1,33 @@+Copyright (c) 2010, João Dias, Simon Peyton Jones, and Norman Ramsey+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++Neither the name of Tufts University nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++Neither the name of Microsoft nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hoopl.cabal view
@@ -0,0 +1,19 @@+Name: hoopl+Version: 3.7.0.0+Description: Higher-order optimization library+License: BSD3+License-file: LICENSE+Author: Norman Ramsey, João Dias, and Simon Peyton Jones+Maintainer: nr@cs.tufts.edu+Build-Type: Simple+Cabal-Version: >=1.2+Synopsis: A library to support dataflow analysis and optimization+Category: Compilers/Interpeters++Library+ Build-Depends: base >= 3 && < 5, containers+ Exposed-modules: Compiler.Hoopl,+ Compiler.Hoopl.Dataflow, Compiler.Hoopl.Graph, + Compiler.Hoopl.GraphUtil, Compiler.Hoopl.MkGraph,+ Compiler.Hoopl.Fuel, Compiler.Hoopl.Label+ ghc-options: -Wall -fno-warn-name-shadowing