diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,35 +3,45 @@ ## Hoopl: A Higher-Order OPtimization Library -API documentation can be found on [Hackage](https://hackage.haskell.org/package/hoopl). +API documentation can be found on +[Hackage](https://hackage.haskell.org/package/hoopl). For detailed explanation +of the library design see paper ["Hoopl: A Modular, Reusable Library for +Dataflow Analysis and +Transformation"](http://research.microsoft.com/en-us/um/people/simonpj/Papers/c--/hoopl-haskell10.pdf) | Directory | Contents | -------------- | --------- -| `paper/` | A paper about Hoopl -| `prototypes/` | A sampling of prototypes and early designs | `src/` | The current official sources to the Cabal package | `testing/` | Tests, including a sample client. See [`testing/README`](testing/README) ### Development Notes -To build the library, change to the src directory and run +#### Building and testing - cabal configure --prefix=$HOME --user # we have no idea what this means +To build the library run: + + cabal configure cabal build cabal install --enable-documentation -To run the tests in the folder testing/, change to the src directory and run +To run the tests in the `testing/` folder run: cabal configure --enable-tests cabal test -To run the tests with the test coverage report, change to the src directory and run +To run the tests with the test coverage report run: - cabal configure --enable-tests -f testcoverage + cabal configure --enable-tests --enable-coverage cabal test You'll need a Haskell Platform, which should include appropriate versions of Cabal and GHC. + +#### Coding style + +Please follow Johan Tibell's +[Haskell Style Guide](https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md) +for all new/modified code. ### Checklist for Making Releases diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,19 @@ # Changelog for [`hoopl` package](http://hackage.haskell.org/package/hoopl) +## 3.10.2.2 *Feb 2017* + This release includes non-API changes. + + - Use cabal builtin options to enable test coverage + + - Move up the constraints of base and containers + + - Refactor the references of the fold family functions to their equivalant foldr functions. + + - Drop the support for 7.0.1 + + - Fix a bug that drops out dominators when joined DPATHs have non-shared nodes in the middle. + + ## 3.10.2.1 *Dec 2015* This release includes only non-functional changes. diff --git a/hoopl.cabal b/hoopl.cabal --- a/hoopl.cabal +++ b/hoopl.cabal @@ -1,5 +1,5 @@ Name: hoopl -Version: 3.10.2.1 +Version: 3.10.2.2 -- NOTE: Don't forget to update ./changelog.md Description: Higher-order optimization library @@ -10,25 +10,20 @@ License: BSD3 License-File: LICENSE Author: Norman Ramsey, Joao Dias, Simon Marlow and Simon Peyton Jones -Maintainer: nr@cs.tufts.edu, andreas.voellmy@gmail.com, email@ningwang.org -Homepage: http://ghc.cs.tufts.edu/hoopl/ +Maintainer: Ning Wang , Michal Terepeta , Norman Ramsey +Homepage: https://github.com/haskell/hoopl Bug-Reports: https://github.com/haskell/hoopl/issues/ Build-Type: Simple Cabal-Version: >=1.10 Synopsis: A library to support dataflow analysis and optimization Category: Compilers/Interpreters Tested-With: GHC>=7.0.1 -Extra-Source-Files: README.md, hoopl.pdf, changelog.md +Extra-Source-Files: README.md, changelog.md Source-repository head Type: git Location: http://git.haskell.org/packages/hoopl.git -flag testcoverage - description: Enable test coverage report - default: False - - Library Default-Language: Haskell2010 Other-Extensions: CPP @@ -45,14 +40,13 @@ Other-Extensions: Safe Trustworthy Hs-Source-Dirs: src - Build-Depends: base >= 4.3 && < 4.10, containers >= 0.4 && < 0.6 + Build-Depends: base >= 4.3 && < 4.11, + containers >= 0.5 && < 0.6 Exposed-Modules: Compiler.Hoopl, Compiler.Hoopl.Internals, Compiler.Hoopl.Wrappers, Compiler.Hoopl.Passes.Dominator, Compiler.Hoopl.Passes.DList --- Compiler.Hoopl.DataflowFold, --- Compiler.Hoopl.OldDataflow, -- The remaining modules are hidden *provisionally* Other-modules: Compiler.Hoopl.Checkpoint, @@ -78,14 +72,11 @@ Type: exitcode-stdio-1.0 Main-Is: Main.hs Hs-Source-Dirs: testing src - Build-Depends: base >= 4.3 && < 4.10, - containers >= 0.4 && < 0.6, + Build-Depends: base >= 4.3 && < 4.10, + containers >= 0.5 && < 0.6, filepath, mtl >= 2.1.3.1, parsec >= 3.1.7, test-framework < 0.9, test-framework-hunit < 0.4, mtl >= 2.1.3.1 - - if flag(testcoverage) - Ghc-Options: -fhpc diff --git a/hoopl.pdf b/hoopl.pdf deleted file mode 100644 Binary files a/hoopl.pdf and /dev/null differ diff --git a/src/Compiler/Hoopl/Combinators.hs b/src/Compiler/Hoopl/Combinators.hs --- a/src/Compiler/Hoopl/Combinators.hs +++ b/src/Compiler/Hoopl/Combinators.hs @@ -37,12 +37,10 @@ -- N.B. rw3, rw3', and rw3a are triples of functions. -- But rw and rw' are single functions. --- @ start comb1.tex thenFwdRw :: forall m n f. Monad m => FwdRewrite m n f -> FwdRewrite m n f -> FwdRewrite m n f --- @ end comb1.tex thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3' where thenrw :: forall m1 e x t t1. @@ -56,11 +54,9 @@ where fwdRes Nothing = rw' n f fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr --- @ start iterf.tex iterFwdRw :: forall m n f. Monad m => FwdRewrite m n f -> FwdRewrite m n f --- @ end iterf.tex iterFwdRw rw3 = wrapFR iter rw3 where iter :: forall a m1 m2 e x t. (Monad m2, Monad m1) => @@ -141,12 +137,10 @@ badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2) --- @ start pairf.tex pairFwd :: forall m n f f'. Monad m => FwdPass m n f -> FwdPass m n f' -> FwdPass m n (f, f') --- @ end pairf.tex pairFwd pass1 pass2 = FwdPass lattice transfer rewrite where lattice = pairLattice (fp_lattice pass1) (fp_lattice pass2) diff --git a/src/Compiler/Hoopl/Dataflow.hs b/src/Compiler/Hoopl/Dataflow.hs --- a/src/Compiler/Hoopl/Dataflow.hs +++ b/src/Compiler/Hoopl/Dataflow.hs @@ -212,27 +212,16 @@ type ARFX thing = forall e x . thing e x -> Fact e f -> m (DG f n e x, Fact x f) -} graph :: Graph n e x -> Fact e f -> m (DG f n e x, Fact x f) --- @ start block.tex -2 - block :: forall e x . - Block n e x -> f -> m (DG f n e x, Fact x f) --- @ end block.tex --- @ start node.tex -4 - node :: forall e x . (ShapeLifter e x) - => n e x -> f -> m (DG f n e x, Fact x f) --- @ end node.tex --- @ start bodyfun.tex - body :: [Label] -> LabelMap (Block n C C) - -> Fact C f -> m (DG f n C C, Fact C f) --- @ 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 -2 + block :: forall e x . Block n e x -> f -> m (DG f n e x, Fact x f) + node :: forall e x . (ShapeLifter e x) => n e x -> f -> m (DG f n e x, Fact x f) + body :: [Label] -> LabelMap (Block n C C) -> Fact C f -> m (DG f n C C, Fact C f) + -- 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' cat :: forall e a x f1 f2 f3. (f1 -> m (DG f n e a, f2)) -> (f2 -> m (DG f n a x, f3)) -> (f1 -> m (DG f n e x, f3)) --- @ end cat.tex graph GNil = \f -> return (dgnil, f) graph (GUnit blk) = block blk @@ -252,7 +241,6 @@ #endif -- Lift from nodes to blocks --- @ start block.tex -2 block BNil = \f -> return (dgnil, f) block (BlockCO l b) = node l `cat` block b block (BlockCC l b n) = node l `cat` block b `cat` node n @@ -260,11 +248,9 @@ block (BMiddle n) = node n block (BCat b1 b2) = block b1 `cat` block b2 --- @ end block.tex block (BSnoc h n) = block h `cat` node n block (BCons n t) = node n `cat` block t --- @ start node.tex -4 node n f = do { grw <- frewrite rewrite n f ; case grw of @@ -275,16 +261,12 @@ f' = fwdEntryFact n f in arfGraph pass' (fwdEntryLabel n) g f' } --- @ end node.tex - -- | Compose fact transformers and concatenate the resulting -- rewritten graphs. {-# INLINE cat #-} --- @ start cat.tex -2 cat ft1 ft2 f = do { (g1,f1) <- ft1 f ; (g2,f2) <- ft2 f1 ; return (g1 `dgSplice` g2, f2) } --- @ end cat.tex arfx :: forall thing x . NonLocal thing => (thing C x -> f -> m (DG f n C x, Fact x f)) @@ -294,10 +276,9 @@ -- 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.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' body entries blockmap init_fbase = fixpoint Fwd lattice do_block entries blockmap init_fbase where @@ -305,9 +286,7 @@ -> m (DG f n C x, Fact x f) do_block b fb = block b entryFact where entryFact = getFact lattice (entryLabel b) 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. @@ -484,9 +463,9 @@ ; 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' + -- 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' body entries blockmap init_fbase = fixpoint Bwd lattice do_block (map entryLabel (backwardBlockList entries blockmap)) blockmap init_fbase where @@ -568,7 +547,6 @@ observeChangedFactBase :: m (Maybe (FactBase f)) -> Maybe (FactBase f) -} --- @ start fptype.tex data Direction = Fwd | Bwd fixpoint :: forall m n f. (CheckpointMonad m, NonLocal n) => Direction @@ -577,8 +555,7 @@ -> [Label] -> LabelMap (Block n C C) -> (Fact C f -> m (DG f n C C, Fact C f)) --- @ end fptype.tex --- @ start fpimp.tex + fixpoint direction lat do_block entries blockmap init_fbase = do -- trace ("fixpoint: " ++ show (case direction of Fwd -> True; Bwd -> False) ++ " " ++ show (mapKeys blockmap) ++ show entries ++ " " ++ show (mapKeys init_fbase)) $ return() @@ -705,11 +682,10 @@ -- TOTALLY internal to Hoopl; each block is decorated with a fact ----------------------------------------------------------------------------- --- @ start dg.tex type Graph = Graph' Block type DG f = Graph' (DBlock f) data DBlock f n e x = DBlock f (Block n e x) -- ^ block decorated with fact --- @ end dg.tex + instance NonLocal n => NonLocal (DBlock f n) where entryLabel (DBlock _ b) = entryLabel b successors (DBlock _ b) = successors b @@ -762,15 +738,12 @@ -- Lowering back: -- - from fact-like things to facts -- Note that the latter two functions depend only on the entry shape. --- @ start node.tex class ShapeLifter e x where singletonDG :: f -> n e x -> DG f n e x fwdEntryFact :: NonLocal n => n e x -> f -> Fact e f fwdEntryLabel :: NonLocal n => n e x -> MaybeC e [Label] ftransfer :: FwdTransfer n f -> n e x -> f -> Fact x f - frewrite :: FwdRewrite m n f -> n e x - -> f -> m (Maybe (Graph n e x, FwdRewrite m n f)) --- @ end node.tex + frewrite :: FwdRewrite m n f -> n e x -> f -> m (Maybe (Graph n e x, FwdRewrite m n f)) bwdEntryFact :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f btransfer :: BwdTransfer n f -> n e x -> Fact x f -> f brewrite :: BwdRewrite m n f -> n e x diff --git a/src/Compiler/Hoopl/Label.hs b/src/Compiler/Hoopl/Label.hs --- a/src/Compiler/Hoopl/Label.hs +++ b/src/Compiler/Hoopl/Label.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, TypeFamilies #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif @@ -17,6 +18,10 @@ import Compiler.Hoopl.Collections import Compiler.Hoopl.Unique +#if !MIN_VERSION_base(4,8,0) +import Data.Traversable (Traversable) +import Data.Foldable (Foldable) +#endif ----------------------------------------------------------------------------- -- Label @@ -64,7 +69,8 @@ ----------------------------------------------------------------------------- -- LabelMap -newtype LabelMap v = LM (UniqueMap v) deriving (Eq, Ord, Show) +newtype LabelMap v = LM (UniqueMap v) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) instance IsMap LabelMap where type KeyOf LabelMap = Label diff --git a/src/Compiler/Hoopl/Passes/Dominator.hs b/src/Compiler/Hoopl/Passes/Dominator.hs --- a/src/Compiler/Hoopl/Passes/Dominator.hs +++ b/src/Compiler/Hoopl/Passes/Dominator.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP, GADTs #-} {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} -#if __GLASGOW_HASKELL__ >= 701 +#if __GLASGOW_HASKELL__ >= 723 {-# LANGUAGE Safe #-} #endif @@ -13,6 +13,7 @@ where import Data.Maybe +import qualified Data.Set as Set import Compiler.Hoopl @@ -47,15 +48,10 @@ extend :: JoinFun DPath extend _ (OldFact (DPath l)) (NewFact (DPath l')) = (changeIf (l `lengthDiffers` j), DPath j) - where j = lcs l l' - lcs :: [Label] -> [Label] -> [Label] -- longest common suffix - lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l' - | length l < length l' = lcs l' l - | otherwise = dropUnlike l l' l - dropUnlike [] [] maybe_like = maybe_like - dropUnlike (x:xs) (y:ys) maybe_like = - dropUnlike xs ys (if x == y then maybe_like else xs) - dropUnlike _ _ _ = error "this can't happen" + where lx = filter (\elem -> Set.member elem common) l + rx = filter (\elem -> Set.member elem common) l' + common = Set.intersection (Set.fromList l) (Set.fromList l') + j = [x | (x, y) <- zip lx rx, x == y] lengthDiffers [] [] = False lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys diff --git a/src/Compiler/Hoopl/Unique.hs b/src/Compiler/Hoopl/Unique.hs --- a/src/Compiler/Hoopl/Unique.hs +++ b/src/Compiler/Hoopl/Unique.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, TypeFamilies #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 701 @@ -26,6 +27,10 @@ import Control.Applicative as AP import Control.Monad (ap,liftM) +#if !MIN_VERSION_base(4,8,0) +import Data.Traversable (Traversable) +import Data.Foldable (Foldable) +#endif ----------------------------------------------------------------------------- -- Unique @@ -61,7 +66,7 @@ setIntersection (US x) (US y) = US (S.intersection x y) setIsSubsetOf (US x) (US y) = S.isSubsetOf x y - setFold k z (US s) = S.fold k z s + setFold k z (US s) = S.foldr k z s setElems (US s) = S.elems s setFromList ks = US (S.fromList ks) @@ -69,7 +74,8 @@ ----------------------------------------------------------------------------- -- UniqueMap -newtype UniqueMap v = UM (M.IntMap v) deriving (Eq, Ord, Show) +newtype UniqueMap v = UM (M.IntMap v) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) instance IsMap UniqueMap where type KeyOf UniqueMap = Unique @@ -94,8 +100,8 @@ mapMap f (UM m) = UM (M.map f m) mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m) - mapFold k z (UM m) = M.fold k z m - mapFoldWithKey k z (UM m) = M.foldWithKey (k . intToUnique) z m + mapFold k z (UM m) = M.foldr k z m + mapFoldWithKey k z (UM m) = M.foldrWithKey (k . intToUnique) z m mapFilter f (UM m) = UM (M.filter f m) mapElems (UM m) = M.elems m