hoopl 3.7.2.2 → 3.7.3.3

raw patch · 3 files changed

+45/−35 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Compiler/Hoopl/Dataflow.hs +42/−33
• README +2/−1
• hoopl.cabal +1/−1

@@ -18,8 +18,8 @@  This was made possible by -* ForwardTransfer looks like this:-    type ForwardTransfer n f+* FwdTransfer looks like this:+    type FwdTransfer 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@@ -35,7 +35,7 @@   [Side note: that means the client must know about    bottom, in case the looupFact returns Nothing] -* Note also that ForwardTransfer *returns* a Fact too;+* Note also that FwdTransfer *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.@@ -58,9 +58,9 @@ module Compiler.Hoopl.Dataflow    ( DataflowLattice(..)   , ChangeFlag(..), changeIf-  , ForwardPass(..),  FwdTransfer, FwdRewrite, SimpleFwdRewrite+  , FwdPass(..),  FwdTransfer, FwdRewrite, SimpleFwdRewrite   , noFwdRewrite, thenFwdRw, shallowFwdRw, deepFwdRw-  , BackwardPass(..), BwdTransfer, BwdRewrite, SimpleBwdRewrite+  , BwdPass(..), BwdTransfer, BwdRewrite, SimpleBwdRewrite   , noBwdRewrite, thenBwdRw, shallowBwdRw, deepBwdRw   , Fact   , analyzeAndRewriteFwd, analyzeAndRewriteBwd@@ -94,7 +94,7 @@ --		Analyze and rewrite forward: the interface ----------------------------------------------------------------------------- -data ForwardPass n f+data FwdPass n f   = FwdPass { fp_lattice  :: DataflowLattice f             , fp_transfer :: FwdTransfer n f             , fp_rewrite  :: FwdRewrite n f }@@ -130,11 +130,14 @@       Just (FwdRes ag rw1a) -> Just (FwdRes ag (rw1a `thenFwdRw` rw2))  deepFwdRw :: FwdRewrite n f -> FwdRewrite n f-deepFwdRw rw = rw `thenFwdRw` deepFwdRw rw+deepFwdRw rw =+  \ n f -> case rw n f of+             Just (FwdRes g rw2) -> Just $ FwdRes g (rw2 `thenFwdRw` deepFwdRw rw)+             Nothing             -> Nothing  analyzeAndRewriteFwd    :: forall n f. Edges n-   => ForwardPass n f+   => FwdPass n f    -> Body n -> FactBase f    -> FuelMonad (Body n, FactBase f) @@ -148,7 +151,7 @@   type ARF thing n -  = forall f e x. ForwardPass n f -> thing e x +  = forall f e x. FwdPass n f -> thing e x                 -> Fact e f -> FuelMonad (RG n f e x, Fact x f)  arfNode :: Edges n => ARF n n@@ -169,7 +172,7 @@ 	                            ; return (g1 `RGCatO` g2, f2) }  arfBody :: Edges n-        => ForwardPass n f -> Body n -> FactBase f+        => FwdPass 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*@@ -199,17 +202,19 @@        ; (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.+forwardBlockList :: Edges n => [Label] -> Body n -> [((Label,Block n C C), [Label])]+-- This produces a list of blocks in order suitable for forward analysis,+-- along with the list of Labels it may depend on for facts. -- ToDo: Do a topological sort to improve convergence rate of fixpoint --       This will require a (HavingSuccessors l) class constraint-forwardBlockList  _ blks = bodyList blks+forwardBlockList  _ blks = map withLbl $ bodyList blks+  where withLbl (l, b) = ((l, b), [l])  ----------------------------------------------------------------------------- --		Backward analysis and rewriting: the interface ----------------------------------------------------------------------------- -data BackwardPass n f+data BwdPass n f   = BwdPass { bp_lattice  :: DataflowLattice f             , bp_transfer :: BwdTransfer n f             , bp_rewrite  :: BwdRewrite n f }@@ -247,7 +252,7 @@ -----------------------------------------------------------------------------  type ARB thing n -  = forall f e x. BackwardPass n f -> thing e x+  = forall f e x. BwdPass n f -> thing e x                -> Fact x f -> FuelMonad (RG n f e x, Fact e f)  arbNode :: Edges n => ARB n n@@ -272,7 +277,7 @@ 	                          ; return (g1 `RGCatO` g2, f1) }  arbBody :: Edges n-        => BackwardPass n f -> Body n -> FactBase f+        => BwdPass 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 $@@ -298,13 +303,15 @@        ; (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+backwardBlockList :: Edges n => [Label] -> Body n -> [((Label, Block n C C), [Label])]+-- This produces a list of blocks in order suitable for backward analysis,+-- along with the list of Labels it may depend on for facts.+backwardBlockList _ blks = map withSuccs $ bodyList blks+  where withSuccs (l, b) = ((l, b), successors b)  analyzeAndRewriteBwd    :: forall n f. Edges n-   => BackwardPass n f +   => BwdPass n f     -> Body n -> FactBase f     -> FuelMonad (Body n, FactBase f) @@ -342,7 +349,7 @@     (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+           Just old_fact -> fact_extend lat new_fact old_fact     new_fbase = extendFactBase fbase lbl res_fact  fixpoint :: forall n f. Edges n@@ -350,41 +357,43 @@          -> DataflowLattice f          -> (Block n C C -> FactBase f               -> FuelMonad (RG n f C C, FactBase f))-         -> FactBase f -> [(Label, Block n C C)]+         -> FactBase f -> [((Label, Block n C C), [Label])]          -> 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) }+                 tfb_fbase tx_fb `delFromFactBase` map fst 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)] +    tx_blocks :: [((Label, Block n C C), [Label])]                -> 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_blocks []              tx_fb = return tx_fb+    tx_blocks (((lbl,blk), deps):bs) tx_fb = tx_block lbl blk deps tx_fb >>= tx_blocks bs+     -- "deps" == Labels the block may _depend_ upon for facts -    tx_block :: Label -> Block n C C +    tx_block :: Label -> Block n C C -> [Label]              -> 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 })+    tx_block lbl blk deps 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]+      = return tx_fb {tfb_lbls = lbls `unionLabelSet` mkLabelSet deps}	-- 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+                 lbls' = lbls `unionLabelSet` mkLabelSet deps+           ; return (TxFB { tfb_lbls  = lbls'+                          , 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_rg    = RGNil                                    , tfb_lbls  = emptyLabelSet }            ; tx_fb <- tx_blocks blocks init_tx_fb            ; case tfb_cha tx_fb of

@@ -14,4 +14,5 @@   1.   Minor version; changes when clients can stay the same  -Version 3.7.2.2 has KNOWN BUGS!  John Dias will update soon.+Version 3.7.3.3 has fixed known bugs.+

@@ -1,5 +1,5 @@ Name:                hoopl-Version:             3.7.2.2+Version:             3.7.3.3 Description:         Higher-order optimization library License:             BSD3 License-file:        LICENSE