NoSlow (empty) → 0.1
raw patch · 34 files changed
+1665/−0 lines, 34 filesdep +basedep +containersdep +criterionsetup-changed
Dependencies added: base, containers, criterion, dph-base, dph-prim-seq, storablevector, template-haskell, uvector, vector
Files
- LICENSE +30/−0
- NoSlow.cabal +116/−0
- NoSlow/Backend/DPH/Prim/Seq.hs +51/−0
- NoSlow/Backend/Interface.hs +39/−0
- NoSlow/Backend/List.hs +15/−0
- NoSlow/Backend/StorableVector.hs +40/−0
- NoSlow/Backend/TH.hs +270/−0
- NoSlow/Backend/Uvector.hs +68/−0
- NoSlow/Backend/Vector.hs +32/−0
- NoSlow/Backend/Vector/Primitive.hs +34/−0
- NoSlow/Backend/Vector/Storable.hs +34/−0
- NoSlow/Main.hs +43/−0
- NoSlow/Main/TH.hs +46/−0
- NoSlow/Main/Tree.hs +32/−0
- NoSlow/Main/Util.hs +30/−0
- NoSlow/Micro/DPH/Prim/Seq.hs +17/−0
- NoSlow/Micro/DPH/Prim/Seq/Double.hs +18/−0
- NoSlow/Micro/Kernels.hs +172/−0
- NoSlow/Micro/List.hs +19/−0
- NoSlow/Micro/List/Double.hs +18/−0
- NoSlow/Micro/StorableVector.hs +18/−0
- NoSlow/Micro/StorableVector/Double.hs +18/−0
- NoSlow/Micro/Uvector.hs +17/−0
- NoSlow/Micro/Uvector/Double.hs +18/−0
- NoSlow/Micro/Vector/Boxed.hs +17/−0
- NoSlow/Micro/Vector/Boxed/Double.hs +18/−0
- NoSlow/Micro/Vector/Primitive.hs +17/−0
- NoSlow/Micro/Vector/Primitive/Double.hs +18/−0
- NoSlow/Micro/Vector/Storable.hs +17/−0
- NoSlow/Micro/Vector/Storable/Double.hs +18/−0
- NoSlow/Util/Base.hs +20/−0
- NoSlow/Util/Computation.hs +88/−0
- Setup.hs +3/−0
- Table.hs +254/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2008-2009, Roman Leshchinskiy+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 name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE 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+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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.+
+ NoSlow.cabal view
@@ -0,0 +1,116 @@+Name: NoSlow+Version: 0.1+License: BSD3+License-File: LICENSE+Author: Roman Leshchinskiy <rl@cse.unsw.edu.au>+Maintainer: Roman Leshchinskiy <rl@cse.unsw.edu.au>+Copyright: Roman Leshchinskiy 2009+Homepage: http://www.cse.unsw.edu.au/~rl/code/darcs/NoSlow+Category: Development, Profiling+Synopsis: Microbenchmarks for various array libraries+Description:+ .+ NoSlow is a benchmark suite for several Haskell array libraries:+ standard lists, primitive sequential arrays from the DPH project,+ uvector, vector (primitive, storable and boxed arrays) and+ storablevector. At the moment, it implements a bunch of fairly random+ loop micro-kernels but will include many more benchmarks in the future.+ .+ In its present state, NoSlow /cannot/ be used to reliably compare the+ performance of the benchmarked libraries. It can be quite helpful for+ identifying cases where a closer inspection of the generated code+ might be warranted, however.+ .+ The package builds two binaries.+ .+ [@noslow -u log@] runs the benchmarks and writes the results to 'log'+ .+ [@noslow-table log > table.html@] outputs the results as a HTML table.+ It also supports the following options.+ .+ [@noslow-table log --type=Double@] only outputs the results of 'Double'+ benchmarks.+ .+ [@noslow-table --diff log1 log2@] produces a table comparing the+ results from 'log1' and 'log2' (2 means the first run was 2x slower+ than the second; 0.5 means 2x faster).+ .+ NoSlow is described in more detail here:+ <http://unlines.wordpress.com/2009/11/27/noslow/>.+ .++Build-Type: Simple+Cabal-Version: >= 1.2++Flag dph-prim-seq+Flag vector+Flag uvector+Flag storablevector++Executable noslow+ Main-Is: NoSlow/Main.hs++ Build-Depends:+ base >= 3 && < 5,+ template-haskell,+ criterion >= 0.2++ if flag(dph-prim-seq)+ build-depends: dph-prim-seq, dph-base+ cpp-options: -DUSE_DPH_PRIM_SEQ++ if flag(vector)+ build-depends: vector+ cpp-options: -DUSE_VECTOR++ if flag(uvector)+ build-depends: uvector+ cpp-options: -DUSE_UVECTOR++ if flag(storablevector)+ build-depends: storablevector+ cpp-options: -DUSE_STORABLEVECTOR++ Ghc-Options:+ -O2++ Other-Modules:+ NoSlow.Backend.DPH.Prim.Seq+ NoSlow.Backend.Interface+ NoSlow.Backend.List+ NoSlow.Backend.StorableVector+ NoSlow.Backend.TH+ NoSlow.Backend.Uvector+ NoSlow.Backend.Vector.Primitive+ NoSlow.Backend.Vector.Storable+ NoSlow.Backend.Vector+ NoSlow.Main.TH+ NoSlow.Main.Tree+ NoSlow.Main.Util+ NoSlow.Micro.DPH.Prim.Seq.Double+ NoSlow.Micro.DPH.Prim.Seq+ NoSlow.Micro.Kernels+ NoSlow.Micro.List.Double+ NoSlow.Micro.List+ NoSlow.Micro.StorableVector.Double+ NoSlow.Micro.StorableVector+ NoSlow.Micro.Uvector.Double+ NoSlow.Micro.Uvector+ NoSlow.Micro.Vector.Boxed.Double+ NoSlow.Micro.Vector.Boxed+ NoSlow.Micro.Vector.Primitive.Double+ NoSlow.Micro.Vector.Primitive+ NoSlow.Micro.Vector.Storable.Double+ NoSlow.Micro.Vector.Storable+ NoSlow.Util.Base+ NoSlow.Util.Computation+ ++Executable noslow-table+ Main-Is: Table.hs++ Build-Depends:+ base >= 3 && < 5,+ containers,+ criterion >=0.2+
+ NoSlow/Backend/DPH/Prim/Seq.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TypeFamilies, TypeSynonymInstances, TypeOperators, PackageImports, CPP #-}+module NoSlow.Backend.DPH.Prim.Seq (+ module U,+ enumFromTo_Int,+ pair, fst, snd++#if __GLASGOW_HASKELL__ < 612+ , filter+#endif+) where++import NoSlow.Util.Computation++import "dph-prim-seq" Data.Array.Parallel.Unlifted as U+import Data.Array.Parallel.Unlifted.Sequential+import Data.Array.Parallel.Base ( (:*:)(..), fstS, sndS )+import qualified Prelude+import Prelude ( Int, Num, Bool )++instance DeepSeq (U.Array a)++instance (TestData a, U.Elt a) => TestData (U.Array a) where+ testData n = U.fromList (testData n)++instance Computation (U.Array a) where+ type Arg (U.Array a) = Nil+ type Res (U.Array a) = U.Array a+ apply x _ = x++#if __GLASGOW_HASKELL__ < 612+filter :: Elt a => (a -> Bool) -> Array a -> Array a+{-# INLINE filter #-}+filter = filterU+#endif++enumFromTo_Int :: Int -> Int -> Array Int+{-# INLINE enumFromTo_Int #-}+enumFromTo_Int = U.enumFromTo++pair :: a -> b -> a :*: b+{-# INLINE pair #-}+pair = (:*:)++fst :: a :*: b -> a+{-# INLINE fst #-}+fst = fstS++snd :: a :*: b -> b+{-# INLINE snd #-}+snd = sndS+
+ NoSlow/Backend/Interface.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE MultiParamTypeClasses, KindSignatures #-}+module NoSlow.Backend.Interface+where++import qualified Prelude+import Prelude ( Num, Int, Bool, undefined )++class Vector (v :: * -> *) a++length :: Vector v a => v a -> Int+replicate :: Vector v a => Int -> a -> v a+map :: (Vector v a, Vector v b) => (a -> b) -> v a -> v b+zip :: (Vector v a, Vector v b) => v a -> v b -> v (Pair a b)+zipWith :: (Vector v a, Vector v b, Vector v c)+ => (a -> b -> c) -> v a -> v b -> v c+sum :: (Num a, Vector v a) => v a -> a+enumFromTo_Int :: Int -> Int -> v Int+filter :: Vector v a => (a -> Bool) -> v a -> v a++type Pair a b = (a,b)++pair :: a -> b -> Pair a b+fst :: Pair a b -> a+snd :: Pair a b -> b+++length = undefined+replicate = undefined+map = undefined+zip = undefined+zipWith = undefined+sum = undefined+enumFromTo_Int = undefined+filter = undefined++pair = undefined+fst = undefined+snd = undefined+
+ NoSlow/Backend/List.hs view
@@ -0,0 +1,15 @@+module NoSlow.Backend.List (+ length, replicate, map, zip, zipWith, sum,+ enumFromTo_Int, filter,+ pair, fst, snd+) where++import NoSlow.Util.Base++enumFromTo_Int :: Int -> Int -> [Int]+{-# INLINE enumFromTo_Int #-}+enumFromTo_Int = enumFromTo++pair :: a -> b -> (a,b)+pair = (,)+
+ NoSlow/Backend/StorableVector.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TypeFamilies #-}+module NoSlow.Backend.StorableVector (+ module Data.StorableVector,+ sum, enumFromTo_Int, zip,+ pair, fst, snd+) where++import NoSlow.Util.Computation+import NoSlow.Util.Base ( Unsupported(..) )++import qualified Data.StorableVector as V+import Data.StorableVector hiding ( zip )+import Foreign ( Storable )+import Prelude hiding ( sum, fst, snd, zip )++instance DeepSeq (V.Vector a)++instance (TestData a, Storable a) => TestData (V.Vector a) where+ testData n = V.pack (testData n)++instance Computation (V.Vector a) where+ type Arg (V.Vector a) = Nil+ type Res (V.Vector a) = V.Vector a+ apply x _ = x++sum :: (Num a, Storable a) => V.Vector a -> a+{-# INLINE sum #-}+sum xs = V.foldl' (+) 0 xs++enumFromTo_Int :: Int -> Int -> V.Vector Int+{-# INLINE enumFromTo_Int #-}+enumFromTo_Int m n = V.sample len (\i -> i+m)+ where+ len = max 0 (n-m+1)++zip = Unsupported+pair = Unsupported+fst = Unsupported+snd = Unsupported+
+ NoSlow/Backend/TH.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE TemplateHaskell, PatternGuards, CPP #-}+module NoSlow.Backend.TH ( Spec(..), specialise, calls ) where++import NoSlow.Util.Base ( named, Unsupported(..) )++import qualified NoSlow.Backend.Interface as I+import Language.Haskell.TH++import Control.Monad ( liftM, liftM2, liftM3 )+import Data.Maybe ( isJust )+import qualified Data.Map as M++interface_module :: String+interface_module = case nameModule ''I.Vector of+ Just s -> s++type Context = (Name, [Type])++data Spec = Spec {+ specModule :: String+ , specContext :: Name -> Name -> [Context]+ , specVars :: [(String, Type)]+ }++newtype SM a = SM { runSM :: Spec -> [Name] -> (a, [Name]) }++instance Monad SM where+ return x = SM $ \_ ns -> (x, ns)++ SM p >>= q = SM $ \s ns ->+ case p s ns of+ (x, ns') -> runSM (q x) s ns'++instance Functor SM where+ fmap = liftM++getSpec :: SM Spec+getSpec = SM $ \s ns -> (s,ns)++reference :: Name -> SM ()+reference name = SM $ \s ns -> ((), name : ns)++specialise :: Spec -> Q [Dec] -> Q [Dec]+specialise spec decsq+ = do+ decs <- decsq+ scs <- mapM (specialiseTopDec spec) decs+ let bad_names = [name | Right name <- scs]+ good_decs = [dec | Left dec <- scs+ , decName dec `notElem` bad_names]++ return $ vector_type : good_decs+ ++ noinline good_decs+ ++ [SigD name (ConT ''Unsupported) | name <- bad_names]+ ++ [ValD (VarP name) (NormalB (ConE 'Unsupported)) []+ | name <- bad_names]+ where+ vector_type = TySynD (mkName "Vector_Type") ty_vars (ty_con `AppT` elem_ty)++ ty_con | Just ty <- lookup "v" (specVars spec) = ty++ (ty_vars, elem_ty)+ | Just ty <- lookup "a" (specVars spec) = ([], ty)+ | otherwise = ([binder a], VarT a)+ where+ a = mkName "a"+#if __GLASGOW_HASKELL__ > 610+ binder = PlainTV+#else+ binder = id+#endif++#if __GLASGOW_HASKELL__ > 610+ noinline decs = [PragmaD $ InlineP name $ InlineSpec False False Nothing+ | SigD name _ <- decs]+#else+ noinline decs = []+#endif++specialiseTopDec :: Spec -> Dec -> Q (Either Dec Name)+specialiseTopDec spec dec+ = case runSM (specialiseDec dec) spec [] of+ (dec', names) ->+ do+ ss <- mapM isSupported names+ return $ if and ss+ then Left dec'+ else Right (decName dec)+ where++decName (SigD name _) = name+decName (FunD name _) = name+decName (ValD (VarP name) _ _) = name++isSupported :: Name -> Q Bool+isSupported name+ = liftM supported (reify name)+ where+ supported (VarI _ (ConT c) _ _)+ | c == ''Unsupported = False+ supported _ = True++specialiseDec :: Dec -> SM Dec+specialiseDec (SigD name ty)+ = SigD name `liftM` specialiseTy ty+specialiseDec (FunD name clauses)+ = FunD name `liftM` mapM specialiseClause clauses+specialiseDec (ValD pat body decs)+ = liftM2 (ValD pat) (specialiseBody body)+ (mapM specialiseDec decs)++specialiseTy :: Type -> SM Type+specialiseTy ty+ = do+ spec <- getSpec+ return $ specialiseTy' spec ty++specialiseTy' :: Spec -> Type -> Type+specialiseTy' spec pty+ | ForallT vars cxt ty <- pty+ = mk_forall (map rename_bndr $ filter keep_bndr vars)+ (spec_cxt cxt)+ (spec_ty ty)++ | otherwise = spec_ty pty+ where+#if __GLASGOW_HASKELL__ > 610+ rename_bndr (PlainTV v) = PlainTV (rename v)+ rename_bndr (KindedTV v k) = KindedTV (rename v) k++ keep_bndr (PlainTV v) = keep_var v+ keep_bndr (KindedTV v _) = keep_var v+#else+ rename_bndr = rename+ keep_bndr = keep_var+#endif++ keep_var v = not $ isJust $ lookup (nameBase v) (specVars spec)+ rename = mkName . nameBase++ mk_forall [] _ ty = ty+ mk_forall vars cxt ty = ForallT vars cxt ty++ spec_cxt = filter var_pred . concatMap spec_pred++#if __GLASGOW_HASKELL__ > 610+ spec_pred (ClassP cls [VarT v, VarT a])+ | cls == ''I.Vector = map (uncurry ClassP)+ $ specContext spec (rename v) (rename a)++ spec_pred (ClassP cls tys) = [ClassP cls $ map spec_ty tys]++ var_pred (ClassP _ tys) = any var_ty tys+#else+ spec_pred (AppT (AppT (ConT cls) (VarT v)) (VarT a))+ | cls == ''I.Vector = map mk_pred+ $ specContext spec (rename v) (rename a)++ spec_pred pred = [spec_ty pred]++ var_pred = var_ty++ mk_pred (cls, tys) = foldl AppT (ConT cls) tys+#endif++ spec_ty (VarT v)+ | Just ty <- lookup (nameBase v) (specVars spec) = ty+ | otherwise = VarT (rename v)++ spec_ty (AppT t u) = spec_ty t `AppT` spec_ty u+ spec_ty ty = ty++ var_ty (VarT v) = True+ var_ty (AppT t u) = var_ty t || var_ty u+ var_ty _ = False++specialiseClause :: Clause -> SM Clause+specialiseClause (Clause pats body decs)+ = liftM2 (Clause pats) (specialiseBody body)+ (mapM specialiseDec decs)++specialiseBody :: Body -> SM Body+specialiseBody (NormalB exp)+ = liftM NormalB+ $ specialiseExp (snd $ removeNamed exp)++specialiseExp :: Exp -> SM Exp+specialiseExp (VarE v)+ | Just mod <- nameModule v+ , mod == interface_module+ = do+ mod <- specModule `fmap` getSpec+ let name = qualify mod v+ reference name+ return $ VarE name++specialiseExp (AppE e1 e2) = liftM2 AppE (specialiseExp e1)+ (specialiseExp e2)++specialiseExp (InfixE me1 e2 me3)+ = liftM3 InfixE (mspec me1) (specialiseExp e2) (mspec me3)+ where+ mspec Nothing = return Nothing+ mspec (Just e) = liftM Just (specialiseExp e)+ +specialiseExp (LamE pats e) = LamE pats `liftM` specialiseExp e+ +specialiseExp (TupE es) = TupE `liftM` mapM specialiseExp es+ +specialiseExp (CondE e1 e2 e3)+ = liftM3 CondE (specialiseExp e1) (specialiseExp e2) (specialiseExp e3)++specialiseExp (LetE decs e)+ = liftM2 LetE (mapM specialiseDec decs)+ (specialiseExp e)++specialiseExp (CaseE _ _) = error "specialiseExp: case"+specialiseExp (DoE _) = error "specialiseExp: do"+specialiseExp (CompE _) = error "specialiseExp: comp"+specialiseExp (ArithSeqE _) = error "specialiseExp: seq"++specialiseExp (ListE es) = ListE `liftM` mapM specialiseExp es++specialiseExp (SigE e ty)+ = liftM2 SigE (specialiseExp e) (specialiseTy ty) ++specialiseExp (RecConE _ _) = error "specialiseExp: rec_con"+specialiseExp (RecUpdE _ _) = error "specialiseExp: rec_upd"++specialiseExp e = return e++calls :: Name -> String -> Q [Dec] -> ExpQ+calls fn mod qdecs+ = do+ decs <- qdecs+ let env = M.fromList (collectNames decs)+ cs <- mapM (call env) [name | SigD name _ <- decs]+ return $ ListE [c | Just c <- cs]+ where+ call env name+ = do+ ok <- isSupported name'+ return $ if ok+ then Just (VarE fn `AppE` LitE (StringL tag) `AppE` VarE name')+ else Nothing+ where+ name' = qualify mod name+ tag = M.findWithDefault (nameBase name) (nameBase name) env++qualify :: String -> Name -> Name+qualify mod name = mkName $ mod ++ '.' : nameBase name++collectNames :: [Dec] -> [(String, String)]+collectNames = foldr collect1 []+ where+ collect1 (FunD name [Clause _ (NormalB exp) _]) xs+ | (Just s, _) <- removeNamed exp = (nameBase name, s) : xs++ collect1 _ xs = xs++removeNamed :: Exp -> (Maybe String, Exp)+removeNamed (VarE f `AppE` LitE (StringL s) `AppE` e)+ | f == 'named = (Just s, e)+removeNamed (InfixE (Just (VarE f `AppE` LitE (StringL s)))+ (VarE apply)+ (Just e))+ | f == 'named+ , apply == '($) = (Just s, e)+removeNamed e = (Nothing, e)+
+ NoSlow/Backend/Uvector.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TypeFamilies, TypeOperators #-}+module NoSlow.Backend.Uvector (+ UA, UArr,++ length, replicate, map, zip, zipWith, sum, enumFromTo_Int, filter,+ pair, fst, snd+) where++import NoSlow.Util.Computation++import Data.Array.Vector+import qualified Prelude+import Prelude ( Int, Num, Bool )++instance DeepSeq (UArr a)++instance (TestData a, UA a) => TestData (UArr a) where+ testData n = toU (testData n)++instance Computation (UArr a) where+ type Arg (UArr a) = Nil+ type Res (UArr a) = UArr a+ apply x _ = x++length :: UA a => UArr a -> Int+{-# INLINE length #-}+length = lengthU++replicate :: UA a => Int -> a -> UArr a+{-# INLINE replicate #-}+replicate = replicateU++map :: (UA a, UA b) => (a -> b) -> UArr a -> UArr b+{-# INLINE map #-}+map = mapU++zip :: (UA a, UA b) => UArr a -> UArr b -> UArr (a :*: b)+{-# INLINE zip #-}+zip = zipU++zipWith :: (UA a, UA b, UA c) => (a -> b -> c) -> UArr a -> UArr b -> UArr c+{-# INLINE zipWith #-}+zipWith = zipWithU++sum :: (Num a, UA a) => UArr a -> a+{-# INLINE sum #-}+sum = sumU++enumFromTo_Int :: Int -> Int -> UArr Int+{-# INLINE enumFromTo_Int #-}+enumFromTo_Int = enumFromToU++filter :: UA a => (a -> Bool) -> UArr a -> UArr a+{-# INLINE filter #-}+filter = filterU++pair :: a -> b -> a :*: b+{-# INLINE pair #-}+pair = (:*:)++fst :: a :*: b -> a+{-# INLINE fst #-}+fst = fstS++snd :: a :*: b -> b+{-# INLINE snd #-}+snd = sndS+
+ NoSlow/Backend/Vector.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TypeFamilies #-}+module NoSlow.Backend.Vector (+ module Data.Vector,++ enumFromTo_Int,+ pair, fst, snd+) where++import NoSlow.Util.Computation++import qualified Data.Vector as V+import Data.Vector++instance DeepSeq a => DeepSeq (V.Vector a) where+ deepSeq xs b = V.foldr deepSeq b xs++instance TestData a => TestData (V.Vector a) where+ testData n = V.fromList (testData n)++instance DeepSeq a => Computation (V.Vector a) where+ type Arg (V.Vector a) = Nil+ type Res (V.Vector a) = V.Vector a+ apply x _ = x++enumFromTo_Int :: Int -> Int -> V.Vector Int+{-# INLINE enumFromTo_Int #-}+enumFromTo_Int = V.enumFromTo++pair :: a -> b -> (a,b)+{-# INLINE pair #-}+pair = (,)+
+ NoSlow/Backend/Vector/Primitive.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TypeFamilies #-}+module NoSlow.Backend.Vector.Primitive (+ module Data.Vector.Primitive,++ enumFromTo_Int, zip,+ pair, fst, snd+) where++import NoSlow.Util.Computation+import NoSlow.Util.Base ( Unsupported(..) )+import qualified Data.Vector.Primitive as V+import Data.Vector.Primitive++import Prelude hiding ( fst, snd, zip )++instance DeepSeq (V.Vector a)++instance (TestData a, V.Prim a) => TestData (V.Vector a) where+ testData n = V.fromList (testData n)++instance Computation (V.Vector a) where+ type Arg (V.Vector a) = Nil+ type Res (V.Vector a) = V.Vector a+ apply x _ = x++enumFromTo_Int :: Int -> Int -> V.Vector Int+{-# INLINE enumFromTo_Int #-}+enumFromTo_Int = V.enumFromTo++zip = Unsupported+pair = Unsupported+fst = Unsupported+snd = Unsupported+
+ NoSlow/Backend/Vector/Storable.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TypeFamilies #-}+module NoSlow.Backend.Vector.Storable (+ module Data.Vector.Storable,++ enumFromTo_Int, zip,+ pair, fst, snd+) where++import NoSlow.Util.Computation+import NoSlow.Util.Base ( Unsupported(..) )+import qualified Data.Vector.Storable as V+import Data.Vector.Storable++import Prelude hiding ( fst, snd, zip )++instance DeepSeq (V.Vector a)++instance (TestData a, V.Storable a) => TestData (V.Vector a) where+ testData n = V.fromList (testData n)++instance Computation (V.Vector a) where+ type Arg (V.Vector a) = Nil+ type Res (V.Vector a) = V.Vector a+ apply x _ = x++enumFromTo_Int :: Int -> Int -> V.Vector Int+{-# INLINE enumFromTo_Int #-}+enumFromTo_Int = V.enumFromTo++zip = Unsupported+pair = Unsupported+fst = Unsupported+snd = Unsupported+
+ NoSlow/Main.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+module Main where++import NoSlow.Main.TH+import NoSlow.Main.Tree+import NoSlow.Main.Util ( (>++<) )++import Criterion.Main+import Criterion.Config++import qualified NoSlow.Micro.List+import qualified NoSlow.Micro.List.Double++#ifdef USE_DPH_PRIM_SEQ+import qualified NoSlow.Micro.DPH.Prim.Seq+import qualified NoSlow.Micro.DPH.Prim.Seq.Double+#endif++#ifdef USE_VECTOR+import qualified NoSlow.Micro.Vector.Primitive+import qualified NoSlow.Micro.Vector.Primitive.Double+import qualified NoSlow.Micro.Vector.Storable+import qualified NoSlow.Micro.Vector.Storable.Double+import qualified NoSlow.Micro.Vector.Boxed+import qualified NoSlow.Micro.Vector.Boxed.Double+#endif++#ifdef USE_UVECTOR+import qualified NoSlow.Micro.Uvector+import qualified NoSlow.Micro.Uvector.Double+#endif++#ifdef USE_STORABLEVECTOR+import qualified NoSlow.Micro.StorableVector+import qualified NoSlow.Micro.StorableVector.Double+#endif++all_kernels = $(benchtrees Poly [t|Double|] kernel_tree)+ >++< $(benchtrees Mono [t|Double|] kernel_tree)++main = defaultMainWith (defaultConfig { cfgPerformGC = ljust True })+ (all_kernels 10000)+
+ NoSlow/Main/TH.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Main.TH+where++import qualified NoSlow.Micro.Kernels as K+import NoSlow.Main.Util+import NoSlow.Backend.TH ( calls )+import NoSlow.Util.Base++import Language.Haskell.TH++data Sort = Poly | Mono++benchtrees :: Sort -> TypeQ -> [KTree] -> ExpQ+benchtrees sort tyq ts+ = do+ ty <- tyq+ varE 'klist `appE` listE (map (benchtree sort ty) ts)++benchtree :: Sort -> Type -> KTree -> ExpQ+benchtree sort ty (KGroup s ts)+ = mk_kgroup s (map (benchtree sort ty) ts)+benchtree sort ty@(ConT c) (KModule s poly_mod)+ = do+ TyConI (TySynD t [_] _) <- reify $ mkName $ poly_mod ++ ".Vector_Type"++ let tag = case sort of+ Poly -> '*' : nameBase c+ Mono -> nameBase c++ real_mod = case sort of+ Poly -> poly_mod+ Mono -> poly_mod ++ '.' : nameBase c++ vec_ty = conT t `appT` return ty+ ty_tag = conE 'Ty `sigE` appT (conT ''Ty) vec_ty++ mk_kgroup s [mk_kernels tag ty_tag real_mod]+ where+ mk_kernels tag ty mod = varE 'kernels `appE` litE (StringL tag)+ `appE` ty+ `appE` calls 'kernel mod K.kernels++mk_kgroup :: String -> [ExpQ] -> ExpQ+mk_kgroup s exps = varE 'kgroup `appE` litE (StringL s) `appE` listE exps+
+ NoSlow/Main/Tree.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}+module NoSlow.Main.Tree+where++import NoSlow.Main.Util++kernel_tree+ = [ KModule "list" "NoSlow.Micro.List"++#ifdef USE_DPH_PRIM_SEQ+ , KGroup "dph-prim" [+ KModule "seq" "NoSlow.Micro.DPH.Prim.Seq"+ ]+#endif++#ifdef USE_VECTOR+ , KGroup "vector" [+ KModule "Primitive" "NoSlow.Micro.Vector.Primitive"+ , KModule "Storable" "NoSlow.Micro.Vector.Storable"+ , KModule "boxed" "NoSlow.Micro.Vector.Boxed"+ ]+#endif++#ifdef USE_UVECTOR+ , KModule "uvector" "NoSlow.Micro.Uvector"+#endif++#ifdef USE_STORABLEVECTOR+ , KModule "storablevector" "NoSlow.Micro.StorableVector"+#endif+ ]+
+ NoSlow/Main/Util.hs view
@@ -0,0 +1,30 @@+module NoSlow.Main.Util ( kernel, kernels, kgroup, klist, KTree(..), (>++<) )+where++import NoSlow.Util.Base+import NoSlow.Util.Computation++import Criterion.Main ( Benchmark, B(..), bench, bgroup ) ++kernel :: Computation b => String -> (Ty a -> b) -> Ty a -> Int -> Benchmark+kernel s a t n = let x = testData n+ in x `deepSeq` bench s $ B run x+ where+ run x = apply (a t) x `deepSeq` ()++kernels :: String -> Ty a -> [Ty a -> Int -> Benchmark] -> Int -> Benchmark+kernels s t bs n = bgroup s [b t n | b <- bs]++data KTree = KGroup String [KTree]+ | KModule String String++kgroup :: String -> [Int -> Benchmark] -> Int -> Benchmark+kgroup s fs n = bgroup s [f n | f <- fs]++klist :: [Int -> Benchmark] -> Int -> [Benchmark]+klist fs n = [f n | f <- fs]++infixr 5 >++<+(>++<) :: (Int -> [Benchmark]) -> (Int -> [Benchmark]) -> Int -> [Benchmark]+(>++<) f g n = f n ++ g n+
+ NoSlow/Micro/DPH/Prim/Seq.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.DPH.Prim.Seq+where++import qualified NoSlow.Backend.DPH.Prim.Seq as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ a -> [(''Impl.Elt, [VarT a])]+ , specVars = [("v", ConT ''Impl.Array)]+ })+ K.kernels)+
+ NoSlow/Micro/DPH/Prim/Seq/Double.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.DPH.Prim.Seq.Double+where++import qualified NoSlow.Backend.DPH.Prim.Seq as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ _ -> []+ , specVars = [("v", ConT ''Impl.Array),+ ("a", ConT ''Double)]+ })+ K.kernels)+
+ NoSlow/Micro/Kernels.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Kernels ( kernels ) where++import qualified NoSlow.Backend.Interface as I+import NoSlow.Util.Base++kernels = [d|++ -- ---------------------------+ -- map, zipWith, replicate+ -- ---------------------------++ -- Add a constant to every element+ --+ -- Doesn't say much on its own but is useful for evaluating the performance+ -- of splus+ splus1 :: (Num a, I.Vector v a) => Ty (v a) -> v a -> v a+ splus1 _ as = named "$a+1" $+ I.map (+1) as++ -- Add a constant to every element (version 2)+ --+ -- No intermediate array should be created, performance should be+ -- similar to splus1+ splus1_r :: (Num a, I.Vector v a) => Ty (v a) -> v a -> v a+ splus1_r _ as = named "$a+^1" $+ I.zipWith (+) as (I.replicate (I.length as) 1)++ -- Add a number to every element+ --+ -- The x should only be inspected once outside the loop. Performance should+ -- be similar to splus1+ splus :: (Num a, I.Vector v a) => Ty (v a) -> v a -> a -> v a+ splus _ as x = named "$a+x" $+ I.map (+x) as++ -- Add a number to every element (version 2)+ --+ -- No intermediate array should be created, performance should be+ -- similar to splus and splus1_r+ splus_r :: (Num a, I.Vector v a) => Ty (v a) -> v a -> a -> v a+ splus_r _ as x = named "$a+^x" $+ I.zipWith (+) as (I.replicate (I.length as) x)++ -- Do these maps get fused?+ splus4 :: (Num a, I.Vector v a) => Ty (v a) -> v a -> a -> v a+ splus4 _ as x = named "$a+x+x+x+x" $+ I.map (+x) $ I.map (+x) $ I.map (+x) $ I.map (+x) as++ -- Elementwise addition+ --+ -- Lower bound on the execution time of the following benchmarks+ plus :: (Num a, I.Vector v a) => Ty (v a) -> v a -> v a -> v a+ plus _ as bs = named "$a+$b" $+ I.zipWith (+) as bs++ -- Checks speed of map/zip compared to zipWith+ plus_zip :: (Num a, I.Vector v a) => Ty (v a) -> v a -> v a -> v a+ plus_zip _ as bs = named "$a+$b(zip)" $+ I.map (\p -> I.fst p + I.snd p) (I.zip as bs)++ -- x should only be inspected once outside the loop+ axpy :: (Num a, I.Vector v a) => Ty (v a) -> a -> v a -> v a -> v a+ axpy _ x as bs = named "x*$a+$b" $+ I.zipWith (+) (I.map (x*) as) bs++ -- Lots of zips can be inefficient with stream fusion.+ mpp :: (Num a, I.Vector v a) => Ty (v a) -> v a -> v a -> v a -> v a -> v a+ mpp _ as bs cs ds = named "($a+$b)*($c+$d)" $+ I.zipWith (*) (I.zipWith (+) as bs) (I.zipWith (+) cs ds)++ -- How does this compare to mpp?+ mpp_zip :: (Num a, I.Vector v a)+ => Ty (v a) -> v a -> v a -> v a -> v a -> v a+ mpp_zip _ as bs cs ds = named "($a+$b)*($c+$d)(zip)" $+ I.map (\p -> (I.fst (I.fst p) + I.snd (I.fst p))+ * (I.fst (I.snd p) + I.snd (I.snd p)))+ (I.zip (I.zip as bs) (I.zip cs ds))++ -- Both x and y should be inspected once.+ mspsp :: (Num a, I.Vector v a) => Ty (v a) -> a -> v a -> a -> v a -> v a+ mspsp _ x as y bs = named "(x+$a)*(y+$b)" $+ I.zipWith (*) (I.map (x+) as) (I.map (y+) bs)++ -- Do we get rid of the replicates?+ mspsp_r :: (Num a, I.Vector v a) => Ty (v a) -> a -> v a -> a -> v a -> v a+ mspsp_r _ x as y bs = named "(^x+$a)*(^y+$b)" $+ I.zipWith (*) (I.zipWith (+) (I.replicate (I.length as) x) as)+ (I.zipWith (+) (I.replicate (I.length bs) y) bs)++ -- -----------+ -- Filters+ -- -----------++ -- Removes all elements from the list, basic test of filter fusion+ filterout :: (Num a, Eq a, I.Vector v a) => Ty (v a) -> v a -> v a+ filterout _ as = named "filter(neq0)(map0)" $+ I.filter (/=0) $ I.map (\x -> x-x) as++ -- Only do the test once, no loop should be executed+ filterout_r :: (Num a, Eq a, I.Vector v a) => Ty (v a) -> Len -> v a+ filterout_r _ (Len n) = named "filter(neq0)(^0)" $+ I.filter (/=0) $ I.replicate n 0++ -- Retain all elements in a list+ filterin :: (Num a, Eq a, I.Vector v a) => Ty (v a) -> v a -> v a+ filterin _ as = named "filter(eq0)(map0)" $+ I.filter (==0) $ I.map (\x -> x-x) as++ -- Only do the test once, should be faster than filterin+ filterin_r :: (Num a, Eq a, I.Vector v a) => Ty (v a) -> Len -> v a+ filterin_r _ (Len n) = named "filter(eq0)(^0)" $+ I.filter (==0) $ I.replicate n 0++ -- Compute x outside of the loop+ zip_filter :: (Num a, Ord a, I.Vector v a)+ => Ty (v a) -> Len -> v a -> v a -> v a+ zip_filter _ (Len n) as bs =+ let x = fromIntegral (n `div` 2)+ in+ I.zipWith (+) (I.filter (<x) as) (I.filter (<x) bs)++ -- Compute (fromIntegral n) outside of the loop+ filter_zip :: (Num a, Ord a, I.Vector v a)+ => Ty (v a) -> Len -> v a -> v a -> v a+ filter_zip _ (Len n) as bs =+ I.filter (< fromIntegral n) (I.zipWith (+) as bs)++ filter_evens :: I.Vector v a => Ty (v a) -> Len -> v a -> v a+ filter_evens _ (Len n) as =+ I.map I.snd+ $ I.filter (even . I.fst)+ $ I.zip (I.enumFromTo_Int 0 (n-1)) as++ -- --------+ -- Sums+ -- --------++ -- Dot product+ dotp :: (Num a, I.Vector v a) => Ty (v a) -> v a -> v a -> a+ dotp _ as bs = named "sum($a*$b)" $+ I.sum (I.zipWith (*) as bs)++ dotp_zip :: (Num a, I.Vector v a) => Ty (v a) -> v a -> v a -> a+ dotp_zip _ as bs = named "sum($a*$b)(zip)" $+ I.sum (I.map (\p -> I.fst p * I.snd p) (I.zip as bs))++ -- sum [1 .. n]+ sumn :: (Num a, I.Vector v a) => Ty (v a) -> Len -> a+ sumn ty (Len n) = named "sum[m..n]" $+ I.sum $ I.map fromIntegral (I.enumFromTo_Int 1 n) `ofType` ty++ sumsq_map :: (Num a, I.Vector v a) => Ty (v a) -> Len -> a+ sumsq_map ty (Len n) = named "sumsq(map)" $+ I.sum $ I.map (\x -> x*x)+ $ I.map fromIntegral (I.enumFromTo_Int 1 n) `ofType` ty++ sumsq_zip :: (Num a, I.Vector v a) => Ty (v a) -> Len -> a+ sumsq_zip ty (Len n) = named "sumsq(zip)" $+ let as = I.map fromIntegral (I.enumFromTo_Int 1 n) `ofType` ty+ in+ I.sum $ I.zipWith (*) as as++ sum_evens :: (Num a, I.Vector v a) => Ty (v a) -> Len -> v a -> a+ sum_evens _ (Len n) as =+ I.sum+ $ I.map I.snd+ $ I.filter (even . I.fst)+ $ I.zip (I.enumFromTo_Int 0 (n-1)) as++ |]+
+ NoSlow/Micro/List.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.List+where++import qualified NoSlow.Backend.List as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++type V a = [a]++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ _ -> []+ , specVars = [("v", ConT ''[])]+ })+ K.kernels)+
+ NoSlow/Micro/List/Double.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.List.Double+where++import qualified NoSlow.Backend.List as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ _ -> []+ , specVars = [("v", ConT ''[]),+ ("a", ConT ''Double)]+ })+ K.kernels)+
+ NoSlow/Micro/StorableVector.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.StorableVector+where++import Foreign ( Storable )+import qualified NoSlow.Backend.StorableVector as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ a -> [(''Storable, [VarT a])]+ , specVars = [("v", ConT ''Impl.Vector)]+ })+ K.kernels)+
+ NoSlow/Micro/StorableVector/Double.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.StorableVector.Double+where++import qualified NoSlow.Backend.StorableVector as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ _ -> []+ , specVars = [("v", ConT ''Impl.Vector),+ ("a", ConT ''Double)]+ })+ K.kernels)+
+ NoSlow/Micro/Uvector.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Uvector+where++import qualified NoSlow.Backend.Uvector as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ a -> [(''Impl.UA, [VarT a])]+ , specVars = [("v", ConT ''Impl.UArr)]+ })+ K.kernels)+
+ NoSlow/Micro/Uvector/Double.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Uvector.Double+where++import qualified NoSlow.Backend.Uvector as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ _ -> []+ , specVars = [("v", ConT ''Impl.UArr),+ ("a", ConT ''Double)]+ })+ K.kernels)+
+ NoSlow/Micro/Vector/Boxed.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Boxed+where++import qualified NoSlow.Backend.Vector as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ _ -> []+ , specVars = [("v", ConT ''Impl.Vector)]+ })+ K.kernels)+
+ NoSlow/Micro/Vector/Boxed/Double.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Boxed.Double+where++import qualified NoSlow.Backend.Vector as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ _ -> []+ , specVars = [("v", ConT ''Impl.Vector),+ ("a", ConT ''Double)]+ })+ K.kernels)+
+ NoSlow/Micro/Vector/Primitive.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Primitive+where++import qualified NoSlow.Backend.Vector.Primitive as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ a -> [(''Impl.Prim, [VarT a])]+ , specVars = [("v", ConT ''Impl.Vector)]+ })+ K.kernels)+
+ NoSlow/Micro/Vector/Primitive/Double.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Primitive.Double+where++import qualified NoSlow.Backend.Vector.Primitive as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ _ -> []+ , specVars = [("v", ConT ''Impl.Vector),+ ("a", ConT ''Double)]+ })+ K.kernels)+
+ NoSlow/Micro/Vector/Storable.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Storable+where++import qualified NoSlow.Backend.Vector.Storable as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ a -> [(''Impl.Storable, [VarT a])]+ , specVars = [("v", ConT ''Impl.Vector)]+ })+ K.kernels)+
+ NoSlow/Micro/Vector/Storable/Double.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Storable.Double+where++import qualified NoSlow.Backend.Vector.Storable as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++$(specialise (Spec {+ specModule = "Impl"+ , specContext = \_ _ -> []+ , specVars = [("v", ConT ''Impl.Vector),+ ("a", ConT ''Double)]+ })+ K.kernels)+
+ NoSlow/Util/Base.hs view
@@ -0,0 +1,20 @@+module NoSlow.Util.Base (+ Ty(..), ofType, named, Unsupported(..),++ Len(..)+) where++data Ty a = Ty++ofType :: a -> Ty a -> a+{-# INLINE ofType #-}+x `ofType` _ = x++named :: String -> a -> a+{-# INLINE named #-}+named s x = x++data Unsupported = Unsupported++newtype Len = Len { unLen :: Int }+
+ NoSlow/Util/Computation.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleContexts, CPP #-}+module NoSlow.Util.Computation (+ DeepSeq(..), TestData(..), Computation(..),++ Nil(..), (:>)(..)+) where++import NoSlow.Util.Base ( Len(..) )++class DeepSeq a where+ deepSeq :: a -> b -> b+ deepSeq = seq++instance DeepSeq Len+instance DeepSeq Int+instance DeepSeq Float+instance DeepSeq Double++instance DeepSeq a => DeepSeq [a] where+ deepSeq xs b = foldr deepSeq b xs++class DeepSeq a => TestData a where+ testData :: Int -> a+ testList :: Int -> [a]++ testList n = replicate n (testData n)++instance TestData Len where+ testData n = Len n++instance TestData Int where+ testData _ = 1+ testList n = [1..n]++instance TestData Float where+ testData _ = 1+ testList n = [1..fromIntegral n]++instance TestData Double where+ testData _ = 1+ testList n = [1..fromIntegral n]++instance TestData a => TestData [a] where+ testData = testList++data x :> xs = x :> xs+data Nil = Nil++instance DeepSeq Nil where+ deepSeq Nil x = x++instance TestData Nil where+ testData _ = Nil++instance (DeepSeq x, DeepSeq xs) => DeepSeq (x :> xs) where+ deepSeq (x :> xs) y = deepSeq x $ deepSeq xs y++instance (TestData x, TestData xs) => TestData (x :> xs) where+ testData n = testData n :> testData n++class (TestData (Arg a), DeepSeq (Res a)) => Computation a where+ type Arg a+ type Res a++ apply :: a -> Arg a -> Res a++#define ComputationResult(ty) \+instance Computation (ty) where { \+ type Arg (ty) = Nil \+; type Res (ty) = ty \+; apply x _ = x }++ComputationResult(Len)+ComputationResult(Int)+ComputationResult(Float)+ComputationResult(Double)++instance DeepSeq a => Computation [a] where+ type Arg [a] = Nil+ type Res [a] = [a]+ apply x _ = x++instance (TestData a, Computation b) => Computation (a -> b) where+ type Arg (a -> b) = a :> Arg b+ type Res (a -> b) = Res b++ apply f (x :> xs) = apply (f x) xs+
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ Table.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE PatternGuards #-}+module Main where++import Criterion.Measurement ( secs )+import qualified Data.Map as M+import Data.List ( nub, intersect, sort, groupBy )+import Text.Read+import System.Environment ( getArgs )+import Control.Monad ( liftM, foldM )+import Text.Printf ( printf )++main = do+ (arg : args) <- getArgs+ if arg == "--diff"+ then doDiff args+ else doTable arg args++doTable file args+ = do+ bs <- readLog file+ table <- foldM procArg (mkTable secs bs) args+ outputHTML table++doDiff (file1 : file2 : args)+ = do+ bs1 <- readLog file1+ bs2 <- readLog file2+ let t = intersectTable ratio cmp (mkTable secs bs1) (mkTable secs bs2)+ table <- foldM procArg t args+ outputHTML table+ where+ ratio d = printf "%.3f" d++ cmp d1 d2 = d1 / d2+++dropPrefix :: String -> String -> Maybe String+dropPrefix "" cs = Just cs+dropPrefix (p : ps) (c : cs)+ | p == c = dropPrefix ps cs+ | otherwise = Nothing++procArg t arg+ | Just s <- dropPrefix "--type=" arg+ = return $ filterColumns (\cfg -> cfgDatatype cfg == s) t++data Cfg = Cfg {+ cfgLibrary :: String+ , cfgSubsystem :: String+ , cfgDatatype :: String+ }+ deriving ( Eq, Ord )++data Library = Library String Int [Subsystem]+data Subsystem = Subsystem String Int [String]++on :: (b -> b -> c) -> (a -> b) -> a -> a -> c+on f g x y = f (g x) (g y)++eqOn :: Eq b => (a -> b) -> a -> a -> Bool+eqOn = on (==)++groupCfgs :: [Cfg] -> [Library]+groupCfgs = map mk_library . groupBy (eqOn cfgLibrary)+ where+ mk_library cfgs@(c:_)+ = let subs = map mk_subsystem $ groupBy (eqOn cfgSubsystem) cfgs+ in+ Library (cfgLibrary c) (sum [n | Subsystem _ n _ <- subs]) subs+ mk_subsystem cfgs@(c:_)+ = let cols = map cfgDatatype cfgs+ in+ Subsystem (cfgSubsystem c) (length cols) cols++instance Show Cfg where+ showsPrec _ cfg = showString (cfgLibrary cfg)+ . sub (cfgSubsystem cfg)+ . showChar '.' . showString (cfgDatatype cfg)+ where+ sub "" = id+ sub s = showChar '.' . showString s++data Entry a = Entry {+ eCfg :: Cfg+ , eName :: String+ , eData :: a+ }++data Table = Table {+ tRows :: [String]+ , tColumns :: [Cfg]+ , tCells :: M.Map String Row+ , tShowCell :: Double -> String+ }+type Row = M.Map Cfg Double++mkTable :: (Double -> String) -> [Entry Double] -> Table+mkTable show es+ = Table {+ tRows = nub $ map eName es+ , tColumns = sort $ nub $ map eCfg es+ , tCells = M.fromListWith M.union [(eName e, unit e) | e <- es]+ , tShowCell = show+ }+ where+ unit e = M.singleton (eCfg e) (eData e)++structure :: Table -> [Library]+structure = groupCfgs . tColumns++cells :: Table -> [(String, [Maybe Double])]+cells (Table { tRows = names+ , tColumns = cfgs+ , tCells = t }) = concatMap row_cells names+ where+ row_cells name = case M.lookup name t of+ Just row -> [(name, map (cell row) cfgs)]+ Nothing -> []++ cell row cfg = M.lookup cfg row++outputHTML :: Table -> IO ()+outputHTML t+ = do+ putStrLn "<html><body>"+ putStrLn $ htmlTable t+ putStrLn "</body></html>"++htmlTable :: Table -> String+htmlTable t = unlines+ [ "<table border=\"1\">"+ , header (structure t) -- tr $ concatMap th ("" : map show (tColumns t))+ , unlines $ map (tr . row) (cells t)+ , "</table>"+ ]+ where+ row (s, cs) = th (concatMap escape s) ++ concatMap cell cs+ cell Nothing = td ""+ cell (Just s) = td (tShowCell t s)++ tr s = "<tr>" ++ s ++ "</tr>"++ th s = "<th>" ++ s ++ "</th>"+ td s = "<td>" ++ s ++ "</td>"++ th' n s = "<th colspan=\"" ++ show n ++ "\">" ++ s ++ "</th>"++ header :: [Library] -> String+ header libs = unlines [+ tr $ th "" ++ concat [th' n lib | Library lib n _ <- libs]+ , tr $ th "" ++ concat [th' n sub | Library _ _ subs <- libs+ , Subsystem sub n _ <- subs]+ , types [s | Library _ _ subs <- libs+ , Subsystem _ _ ss <- subs+ , s <- ss]+ ]++ types (s : ss)+ | all (s==) ss = ""+ | otherwise = tr $ th "" ++ concatMap th (s:ss)++ escape '<' = "<"+ escape '>' = ">"+ escape '&' = "&"+ escape c = [c]++filterRows :: (String -> Bool) -> Table -> Table+filterRows f t@(Table { tRows = tRows, tCells = tCells })+ = t { tRows = filter f tRows+ , tCells = M.filterWithKey (\s _ -> f s) tCells }++filterColumns :: (Cfg -> Bool) -> Table -> Table+filterColumns f t@(Table { tColumns = tColumns, tCells = tCells })+ = t { tColumns = filter f tColumns+ , tCells = M.map (M.filterWithKey (\cfg _ -> f cfg)) tCells+ }++intersectTable :: (Double -> String) -> (Double -> Double -> Double)+ -> Table -> Table -> Table+intersectTable show f t1 t2+ = Table { tRows = intersect (tRows t1) (tRows t2)+ , tColumns = intersect (tColumns t1) (tColumns t2)+ , tCells = M.intersectionWith (M.intersectionWith f)+ (tCells t1) (tCells t2)+ , tShowCell = show+ }++{-+data State = State {+ stOriginal :: Table Double+ , stResult :: Table Double+ }++mapOriginal :: (Table Double -> Table Double) -> State -> State+mapOriginal f st@(State { stOriginal = t }) = st { stOriginal = f t }++mapResult :: (Table Double -> Table Double) -> State -> State+mapResult f st@(State { stResult = t }) = st { stResult = f t }+-}+++newtype Benchmark = Benchmark { unBenchmark :: Entry Double }++readLog :: FilePath -> IO [Entry Double]+readLog file = (proc_lines . lines) `liftM` readFile file+ where+ proc_lines (h : r)+ | h == header = map (unBenchmark . read) r+ | otherwise = error "Invalid file"++ header = "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB"+++instance Read Benchmark where+ readPrec = do+ tag <- readPrec+ comma+ mean <- readPrec+ comma+ readPrec :: ReadPrec Double -- meanlb+ comma+ readPrec :: ReadPrec Double -- meanub+ comma+ readPrec :: ReadPrec Double -- stddev+ comma+ readPrec :: ReadPrec Double -- stddevlb+ comma+ readPrec :: ReadPrec Double -- stddevub+ case split_tag tag of+ (library, subsystem, datatype, name)+ -> return $ Benchmark+ $ Entry {+ eCfg = Cfg { cfgLibrary = library+ , cfgSubsystem = subsystem+ , cfgDatatype = datatype+ }+ , eName = name+ , eData = mean+ }+ where+ comma = do+ c <- get+ if c == ',' then return () else pfail++ split_tag s = case split '/' s of+ [library,subsystem,datatype,benchmark]+ -> (library,subsystem,datatype,benchmark)+ [library,datatype,benchmark]+ -> (library,"",datatype,benchmark)+ + split c xs = case span (/= c) xs of+ (ys,[]) -> [ys]+ (ys, _ : zs) -> ys : split c zs+