NoSlow 0.1.1 → 0.2
raw patch · 46 files changed
+2221/−516 lines, 46 filesdep +arraydep +statisticsdep ~criteriondep ~vector
Dependencies added: array, statistics
Dependency ranges changed: criterion, vector
Files
- NoSlow.cabal +65/−19
- NoSlow/Analyse/Main.hs +170/−0
- NoSlow/Analyse/Table.hs +145/−0
- NoSlow/Backend/DPH/Prim/Seq.hs +116/−12
- NoSlow/Backend/Interface.hs +52/−1
- NoSlow/Backend/List.hs +53/−3
- NoSlow/Backend/StorableVector.hs +51/−9
- NoSlow/Backend/TH.hs +44/−7
- NoSlow/Backend/Uvector.hs +104/−8
- NoSlow/Backend/Vector.hs +33/−9
- NoSlow/Backend/Vector/Primitive.hs +23/−9
- NoSlow/Backend/Vector/Storable.hs +22/−9
- NoSlow/Backend/Vector/Unboxed.hs +50/−0
- NoSlow/Main.hs +176/−5
- NoSlow/Main/TH.hs +17/−23
- NoSlow/Main/Tree.hs +40/−13
- NoSlow/Main/Util.hs +16/−8
- NoSlow/Micro/Kernels.hs +126/−73
- NoSlow/Micro/Vector/Unboxed.hs +16/−0
- NoSlow/Micro/Vector/Unboxed/Double.hs +16/−0
- NoSlow/Micro/Vector/Unsafe/Boxed.hs +14/−0
- NoSlow/Micro/Vector/Unsafe/Boxed/Double.hs +16/−0
- NoSlow/Micro/Vector/Unsafe/Primitive.hs +14/−0
- NoSlow/Micro/Vector/Unsafe/Primitive/Double.hs +14/−0
- NoSlow/Micro/Vector/Unsafe/Storable.hs +14/−0
- NoSlow/Micro/Vector/Unsafe/Storable/Double.hs +14/−0
- NoSlow/Micro/Vector/Unsafe/Unboxed.hs +14/−0
- NoSlow/Micro/Vector/Unsafe/Unboxed/Double.hs +14/−0
- NoSlow/Mini/DPH/Prim/Seq.hs +16/−0
- NoSlow/Mini/Kernels.hs +207/−0
- NoSlow/Mini/List.hs +16/−0
- NoSlow/Mini/StorableVector.hs +16/−0
- NoSlow/Mini/Uvector.hs +16/−0
- NoSlow/Mini/Vector/Boxed.hs +16/−0
- NoSlow/Mini/Vector/Primitive.hs +16/−0
- NoSlow/Mini/Vector/Storable.hs +16/−0
- NoSlow/Mini/Vector/Unboxed.hs +16/−0
- NoSlow/Mini/Vector/Unsafe/Boxed.hs +14/−0
- NoSlow/Mini/Vector/Unsafe/Primitive.hs +14/−0
- NoSlow/Mini/Vector/Unsafe/Storable.hs +14/−0
- NoSlow/Mini/Vector/Unsafe/Unboxed.hs +14/−0
- NoSlow/Util/Base.hs +7/−4
- NoSlow/Util/Computation.hs +190/−50
- NoSlow/Util/Opts.hs +141/−0
- NoSlow/Util/Tag.hs +43/−0
- Table.hs +0/−254
NoSlow.cabal view
@@ -1,11 +1,11 @@ Name: NoSlow-Version: 0.1.1+Version: 0.2 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+Copyright: Roman Leshchinskiy 2009-10+Homepage: http://code.haskell.org/NoSlow Category: Development, Profiling Synopsis: Microbenchmarks for various array libraries Description:@@ -14,30 +14,44 @@ 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.+ loop micro-kernels and a couple of small array algorithms. It 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.+ The package builds two binaries: @noslow@ and @noslow-table@. .- [@noslow -u log@] runs the benchmarks and writes the results to 'log'+ [@noslow -o 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 -o table.html --html@] outputs the results from+ @log@ as a HTML table. .- [@noslow-table log --type=Double@] only outputs the results of 'Double'- benchmarks.+ [@noslow-table log -o table.html --raw --csv@] outputs the results+ from @log@ as a CSV file suitable for importing into spreadsheets. .- [@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-table --diff log1 log2@ -o table.html@] 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-table --help@] lists additional options.+ . NoSlow is described in more detail here: <http://unlines.wordpress.com/2009/11/27/noslow/>. .+ Changes since version 0.1+ .+ * Renamed and reorganised loop kernels+ .+ * Several small array algorithms organised in the new+ benchmark category @mini@+ .+ * More reliable benchmark execution+ .+ * Support for producing CSV files+ . Build-Type: Simple Cabal-Version: >= 1.2@@ -52,18 +66,20 @@ Build-Depends: base >= 3 && < 5,+ array, template-haskell,- criterion >= 0.2 && < 0.3+ criterion >= 0.4 && < 0.5 Extensions:- MultiParamTypeClasses+ MultiParamTypeClasses,+ FlexibleInstances if flag(dph-prim-seq) build-depends: dph-prim-seq, dph-base cpp-options: -DUSE_DPH_PRIM_SEQ if flag(vector)- build-depends: vector >= 0.4+ build-depends: vector >= 0.5 cpp-options: -DUSE_VECTOR if flag(uvector)@@ -86,13 +102,14 @@ NoSlow.Backend.Uvector NoSlow.Backend.Vector.Primitive NoSlow.Backend.Vector.Storable+ NoSlow.Backend.Vector.Unboxed NoSlow.Backend.Vector NoSlow.Main.TH NoSlow.Main.Tree NoSlow.Main.Util+ NoSlow.Micro.Kernels 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@@ -105,15 +122,44 @@ NoSlow.Micro.Vector.Primitive NoSlow.Micro.Vector.Storable.Double NoSlow.Micro.Vector.Storable+ NoSlow.Micro.Vector.Unboxed+ NoSlow.Micro.Vector.Unboxed.Double+ NoSlow.Micro.Vector.Unsafe.Unboxed+ NoSlow.Micro.Vector.Unsafe.Unboxed.Double+ NoSlow.Micro.Vector.Unsafe.Primitive+ NoSlow.Micro.Vector.Unsafe.Primitive.Double+ NoSlow.Micro.Vector.Unsafe.Storable+ NoSlow.Micro.Vector.Unsafe.Storable.Double+ NoSlow.Micro.Vector.Unsafe.Boxed+ NoSlow.Micro.Vector.Unsafe.Boxed.Double+ NoSlow.Mini.Kernels+ NoSlow.Mini.DPH.Prim.Seq+ NoSlow.Mini.List+ NoSlow.Mini.StorableVector+ NoSlow.Mini.Uvector+ NoSlow.Mini.Vector.Boxed+ NoSlow.Mini.Vector.Primitive+ NoSlow.Mini.Vector.Storable+ NoSlow.Mini.Vector.Unboxed+ NoSlow.Mini.Vector.Unsafe.Unboxed+ NoSlow.Mini.Vector.Unsafe.Primitive+ NoSlow.Mini.Vector.Unsafe.Storable+ NoSlow.Mini.Vector.Unsafe.Boxed NoSlow.Util.Base NoSlow.Util.Computation+ NoSlow.Util.Tag+ NoSlow.Util.Opts Executable noslow-table- Main-Is: Table.hs+ Main-Is: NoSlow/Analyse/Main.hs Build-Depends: base >= 3 && < 5, containers,- criterion >=0.2+ criterion >=0.2,+ statistics >= 0.3.5 && < 4++ Other-Modules:+ NoSlow.Analyse.Table
+ NoSlow/Analyse/Main.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE PatternGuards #-}+module Main where++import NoSlow.Analyse.Table+import NoSlow.Util.Tag+import qualified NoSlow.Util.Opts as O++import Criterion.Measurement ( secs )+import Text.Read+import System.Console.GetOpt+import System.Environment ( getArgs, getProgName )+import Data.Version ( showVersion )+import Control.Monad ( liftM, foldM )+import Text.Printf ( printf )+import System.IO++import Paths_NoSlow++main = do+ args <- getArgs+ case args of+ arg : args' | arg == "-d" || arg == "--diff" -> doDiff args'+ _ -> doTable args++data Opts = Opts {+ optOutputFile :: FilePath+ , optOutput :: FilePath -> Table -> IO ()+ , optTransTable :: Table -> Table+ }++defaultTableOpts = Opts { optOutputFile = ""+ , optOutput = outputHTML+ , optTransTable = id }++type OptM = O.OptM Opts++tbl :: (Table -> Table) -> Opts -> Opts+tbl f opts@(Opts { optTransTable = g }) = opts { optTransTable = f . g }++raw :: Table -> Table+raw t = t { tShowCell = printf "%f" }++commonOptions :: [OptDescr OptM]+commonOptions = [+ Option ['b'] ["bench"]+ (O.listArg return (tbl . sel_rows) "LIST")+ "only process some benchmarks"+ , Option ['l'] ["lib"]+ (O.selArg O.matchLib (tbl . filterTags) "LIST")+ "only process the specified libraries"+ , Option ['g'] ["group"]+ (O.selArg O.matchGroup (tbl . filterTags) "LIST")+ "only process benchmarks from the specified group"+ , Option ['o'] ["output"]+ (O.reqArg (\s opt -> opt { optOutputFile = s }) "FILE")+ "store the output in this file"+ , Option [] ["raw"]+ (O.noArg $ tbl raw)+ "output the raw data"+ , Option [] ["html"]+ (O.noArg $ \opt -> opt { optOutput = outputHTML })+ "output a HTML table"+ , Option [] ["csv"]+ (O.noArg $ \opt -> opt { optOutput = outputCSV })+ "output a CSV table"+ , Option ['V'] ["version"]+ (O.helpArg printVersion)+ "output version, then exit"+ , Option ['h','?'] ["help"]+ (O.helpArg printUsage)+ "output help"+ ]+ where+ sel_rows ss = filterRows (\s -> s `elem` ss)++printVersion :: IO ()+printVersion = putStrLn (showVersion version)++printUsage :: IO ()+printUsage = do+ p <- getProgName+ putStrLn (usageInfo ("Usage: " ++ p ++ " [OPTION | FILE] ...\n" +++ " " ++ p ++ " [-d | --diff] FILE1 FILE2 [OPTIONS]") + commonOptions)+++doTable args+ = do+ (opts, rest) <- O.parse defaultTableOpts commonOptions args+ ts <- mapM readLog $ if null rest then ["-"] else rest+ output opts $ optTransTable opts $ foldr1 union ts++doDiff args+ = do+ (opts, rest) <- O.parse defaultTableOpts commonOptions args+ case rest of+ [file1,file2] -> do+ t1 <- readLog file1+ t2 <- readLog file2+ output opts $ optTransTable opts+ $ intersect ratio cmp t1 t2++ _ | length rest > 2 -> O.printError "too many arguments"+ | otherwise -> O.printError "not enough arguments"+ where+ ratio d = printf "%.3f" d++ cmp d1 d2 = d1 / d2+++output :: Opts -> Table -> IO ()+output o = optOutput o (optOutputFile o)++outputHTML :: FilePath -> Table -> IO ()+outputHTML file t+ = with_file file $ \h ->+ do+ hPutStrLn h "<html><body>"+ hPutStrLn h (html $ prune t)+ hPutStrLn h "</body></html>"+ where+ with_file "" f = f stdout+ with_file file f = withFile file WriteMode f ++outputCSV :: FilePath -> Table -> IO ()+outputCSV file t+ = with_file file $ \h ->+ hPutStrLn h (csv $ prune t)+ where+ with_file "" f = f stdout+ with_file file f = withFile file WriteMode f ++newtype Benchmark = Benchmark { unBenchmark :: (Tag, Double) }++readLog :: FilePath -> IO Table+readLog file = (table secs . proc_lines . lines) `liftM` read_file file+ where+ proc_lines (h : r)+ | h == header = map (unBenchmark . read) r+ | otherwise = error "Invalid file"++ header = "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB"++ read_file "-" = getContents+ read_file file = readFile file+++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 reads tag of+ [(t, "")] + -> return $ Benchmark (t, mean)+ where+ comma = do+ c <- get+ if c == ',' then return () else pfail+
+ NoSlow/Analyse/Table.hs view
@@ -0,0 +1,145 @@+module NoSlow.Analyse.Table (+ Table(..),++ table,+ filterTags, filterRows,+ intersect, union, prune,++ html, csv+) where++import NoSlow.Util.Tag++import qualified Data.Map as M+import qualified Data.List as L++data Table = Table {+ tRows :: [String]+ , tCells :: M.Map Tag Double+ , tShowCell :: Double -> String+ }++-- | Create new table+table :: (Double -> String) -> [(Tag, Double)] -> Table+table show es+ = Table {+ tRows = L.nub $ map (tagName . fst) es+ , tCells = M.fromList es+ , tShowCell = show+ }++filterTags :: (Tag -> Bool) -> Table -> Table+filterTags f t@(Table { tCells = tCells })+ = t { tCells = M.filterWithKey (\tag _ -> f tag) tCells }++filterRows :: (String -> Bool) -> Table -> Table+filterRows f t@(Table { tRows = tRows, tCells = tCells })+ = t { tRows = filter f tRows+ , tCells = M.filterWithKey (\tag _ -> f (tagName tag)) tCells+ }++intersect :: (Double -> String) -> (Double -> Double -> Double)+ -> Table -> Table -> Table+intersect show f t1 t2+ = Table { tRows = L.intersect (tRows t1) (tRows t2)+ , tCells = M.intersectionWith f (tCells t1) (tCells t2)+ , tShowCell = show+ }++union :: Table -> Table -> Table+union t1 t2+ = Table { tRows = tRows t1 ++ (tRows t2 L.\\ tRows t1)+ , tCells = M.unionWith (\x y -> y) (tCells t1) (tCells t2)+ , tShowCell = tShowCell t1+ }++prune :: Table -> Table+prune t+ = t { tRows = filter keep (tRows t) }+ where+ keep s = any (\t -> tagName t == s) $ M.keys $ tCells t+ ++columns :: Table -> [Tag]+columns = map head . spans (==) . map clear_name . map fst . M.toAscList . tCells+ where+ clear_name tag = tag { tagName = "" }++header :: [Tag] -> [[(Int, String)]]+header cols+ | all (head groups ==) groups = [libraries, subsystems]+ | otherwise = [libraries, subsystems, groups]+ where+ libraries = [(length ts, tagLibrary $ head ts) | ts <- libs]+ subsystems = [(length ts, tagSubsystem $ head ts)+ | us <- libs+ , ts <- spans (eqOn tagSubsystem) us]+ groups = [(1, tagGroup t) | t <- cols]++ libs = spans (eqOn tagLibrary) cols++cells :: [Tag] -> Table -> [[Maybe Double]]+cells cols (Table { tRows = rows, tCells = t })+ = map mk_row rows+ where+ mk_row name = [M.lookup (set_name tag name) t | tag <- cols]++ set_name tag name = tag { tagName = name }++spans :: (a -> a -> Bool) -> [a] -> [[a]]+spans eq [] = []+spans eq (x:xs) = (x:ys) : spans eq zs+ where+ (ys,zs) = span (eq x) xs++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 (==)+++html :: Table -> String+html t = unlines+ [ "<table border=\"1\">"+ , unlines $ map (tr . header_row) (header cols)+ , unlines $ map (tr . row) $ zip (tRows t) (cells cols t)+ , "</table>"+ ]+ where+ cols = columns t++ 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' 1 s = th s+ th' n s = "<th colspan=\"" ++ show n ++ "\">" ++ s ++ "</th>"++ header_row cs+ = th "" ++ concatMap (uncurry th') cs++ escape '<' = "<"+ escape '>' = ">"+ escape '&' = "&"+ escape c = [c]++csv :: Table -> String+csv t = unlines+ [ L.intercalate "," $ "Kernel" : map show cols+ , unlines $ map row $ zip (tRows t) (cells cols t)+ ]+ where+ cols = columns t++ row (t, cs) = L.intercalate "," $ t : map cell cs++ cell Nothing = ""+ cell (Just s) = tShowCell t s++
NoSlow/Backend/DPH/Prim/Seq.hs view
@@ -1,46 +1,142 @@ {-# LANGUAGE TypeFamilies, TypeSynonymInstances, TypeOperators, PackageImports, CPP #-} module NoSlow.Backend.DPH.Prim.Seq ( module U,- enumFromTo_Int,- pair, fst, snd+ null, imap, enumFromTo_Int, cons, head, tail, index, append, take, slice,+ prescanl',+ backpermute, update_, minIndex, maxIndex, unstablePartition,+ prescanr',+ pair, from2, fst, snd, triple, from3 #if __GLASGOW_HASKELL__ < 612- , filter+ , filter, drop, update, and #endif ) where import NoSlow.Util.Computation+import NoSlow.Util.Base ( Unsupported(..) ) 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 Data.Array.Parallel.Unlifted.Sequential as S+import Data.Array.Parallel.Base ( (:*:)(..), fstS, sndS, uncurryS ) import qualified Prelude-import Prelude ( Int, Num, Bool )+import Prelude ( Num, Ord, Int, Bool, (.), flip, not ) instance DeepSeq (U.Array a) instance (TestData a, U.Elt a) => TestData (U.Array a) where- testData n = U.fromList (testData n)+ testData = testList -instance Computation (U.Array a) where- type Arg (U.Array a) = Nil- type Res (U.Array a) = U.Array a- apply x _ = x+instance U.Elt a => ListLike U.Array a where+ fromList = U.fromList +null :: Elt a => Array a -> Bool+{-# INLINE null #-}+null = S.nullU++imap :: (Elt a, Elt b) => (Int -> a -> b) -> Array a -> Array b+{-# INLINE imap #-}+imap f xs = U.map (uncurryS f) (U.indexed xs)+ #if __GLASGOW_HASKELL__ < 612 filter :: Elt a => (a -> Bool) -> Array a -> Array a {-# INLINE filter #-}-filter = filterU+filter = S.filterU #endif +cons :: Elt a => a -> Array a -> Array a+{-# INLINE cons #-}+cons = S.consU++head :: Elt a => Array a -> a+{-# INLINE head #-}+head xs = xs !: 0++tail :: Elt a => Array a -> Array a+{-# INLINE tail #-}+tail = S.tailU+ enumFromTo_Int :: Int -> Int -> Array Int {-# INLINE enumFromTo_Int #-} enumFromTo_Int = U.enumFromTo +prescanl' :: (Elt a, Elt b) => (a -> b -> a) -> a -> Array b -> Array a+{-# INLINE prescanl' #-}+prescanl' = S.scanlU++prescanr' :: (Elt a, Elt b) => (a -> b -> b) -> b -> Array a -> Array b+{-# INLINE prescanr' #-}+prescanr' f z xs = S.scanlU (flip f) z (S.reverseU xs)++index :: Elt a => Array a -> Int -> a+{-# INLINE index #-}+index = (!:)++append :: Elt a => Array a -> Array a -> Array a+{-# INLINE append #-}+append = (+:+)++take :: Elt a => Int -> Array a -> Array a+{-# INLINE take #-}+take = S.takeU++#if __GLASGOW_HASKELL__ < 612+drop :: Elt a => Int -> Array a -> Array a+{-# INLINE drop #-}+drop = S.dropU+#endif++slice :: Elt a => Array a -> Int -> Int -> Array a+{-# INLINE slice #-}+slice = S.sliceU++backpermute :: Elt a => Array a -> Array Int -> Array a+{-# INLINE backpermute #-}+backpermute = bpermute++update_ :: Elt a => Array a -> Array Int -> Array a -> Array a+{-# INLINE update_ #-}+#if __GLASGOW_HASKELL__ < 612+update_ xs is ys = S.updateU xs (zip is ys)+#else+update_ xs is ys = update xs (zip is ys)+#endif++#if __GLASGOW_HASKELL__ < 612+update :: Elt a => Array a -> Array (Int :*: a) -> Array a+{-# INLINE update #-}+update = S.updateU+#endif++#if __GLASGOW_HASKELL__ < 612+and :: Array Bool -> Bool+{-# INLINE and #-}+and = S.andU+#endif++minIndex :: (Ord a, Elt a) => Array a -> Int+{-# INLINE minIndex #-}+minIndex = S.minimumIndexU++maxIndex :: (Ord a, Elt a) => Array a -> Int+{-# INLINE maxIndex #-}+maxIndex = S.maximumIndexU++unstablePartition :: Elt a => (a -> Bool) -> Array a -> (Array a, Array a)+{-# INLINE unstablePartition #-}+#if __GLASGOW_HASKELL__ < 612+unstablePartition f xs = (S.filterU f xs, S.filterU (not . f) xs)+#else+unstablePartition f xs = (U.filter f xs, U.filter (not . f) xs)+#endif+ pair :: a -> b -> a :*: b {-# INLINE pair #-} pair = (:*:) +from2 :: a :*: b -> (a,b)+{-# INLINE from2 #-}+from2 (a :*: b) = (a,b)+ fst :: a :*: b -> a {-# INLINE fst #-} fst = fstS@@ -48,4 +144,12 @@ snd :: a :*: b -> b {-# INLINE snd #-} snd = sndS++triple :: a -> b -> c -> a :*: b :*: c+{-# INLINE triple #-}+triple a b c = a :*: b :*: c++from3 :: a :*: b :*: c -> (a,b,c)+{-# INLINE from3 #-}+from3 (a :*: b :*: c) = (a,b,c)
NoSlow/Backend/Interface.hs view
@@ -3,37 +3,88 @@ where import qualified Prelude-import Prelude ( Num, Int, Bool, undefined )+import Prelude ( Num, Ord, Int, Bool, undefined ) class Vector (v :: * -> *) a +null :: Vector v a => v a -> Bool length :: Vector v a => v a -> Int replicate :: Vector v a => Int -> a -> v a+cons :: Vector v a => a -> v a -> v a+head :: Vector v a => v a -> a+tail :: Vector v a => v a -> v a map :: (Vector v a, Vector v b) => (a -> b) -> v a -> v b+imap :: (Vector v a, Vector v b) => (Int -> a -> b) -> v a -> v b zip :: (Vector v a, Vector v b) => v a -> v b -> v (Pair a b)+zip3 :: (Vector v a, Vector v b, Vector v c)+ => v a -> v b -> v c -> v (Triple a b c) zipWith :: (Vector v a, Vector v b, Vector v c) => (a -> b -> c) -> v a -> v b -> v c+unzip :: (Vector v a, Vector v b) => v (a,b) -> Pair (v a) (v b) sum :: (Num a, Vector v a) => v a -> a+and :: v Bool -> Bool+prescanl' :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a+prescanr' :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b enumFromTo_Int :: Int -> Int -> v Int filter :: Vector v a => (a -> Bool) -> v a -> v a+index :: Vector v a => v a -> Int -> a+append :: Vector v a => v a -> v a -> v a+take :: Vector v a => Int -> v a -> v a+drop :: Vector v a => Int -> v a -> v a+slice :: Vector v a => v a -> Int -> Int -> v a+backpermute :: Vector v a => v a -> v Int -> v a+update :: Vector v a => v a -> v (Pair Int a) -> v a+update_ :: Vector v a => v a -> v Int -> v a -> v a+minIndex :: (Ord a, Vector v a) => v a -> Int+maxIndex :: (Ord a, Vector v a) => v a -> Int+unstablePartition :: Vector v a => (a -> Bool) -> v a -> (v a, v a) type Pair a b = (a,b)+type Triple a b c = (a,b,c) pair :: a -> b -> Pair a b+from2 :: Pair a b -> (a,b) fst :: Pair a b -> a snd :: Pair a b -> b +triple :: a -> b -> c -> Triple a b c+from3 :: Triple a b c -> (a,b,c) +null = undefined length = undefined replicate = undefined+cons = undefined+head = undefined+tail = undefined map = undefined+imap = undefined zip = undefined+zip3 = undefined zipWith = undefined+unzip = undefined sum = undefined+and = undefined+prescanl' = undefined+prescanr' = undefined enumFromTo_Int = undefined filter = undefined+index = undefined+append = undefined+take = undefined+drop = undefined+slice = undefined+backpermute = undefined+update = undefined+update_ = undefined+minIndex = undefined+maxIndex = undefined+unstablePartition = undefined pair = undefined+from2 = undefined fst = undefined snd = undefined++triple = undefined+from3 = undefined
NoSlow/Backend/List.hs view
@@ -1,15 +1,65 @@ module NoSlow.Backend.List (- length, replicate, map, zip, zipWith, sum,- enumFromTo_Int, filter,- pair, fst, snd+ module Prelude,+ cons, imap, enumFromTo_Int, index, append, slice, prescanl', prescanr',+ backpermute, update, update_, minIndex, maxIndex, unstablePartition,+ pair, from2, triple, from3 ) where import NoSlow.Util.Base+import Data.List +imap :: (Int -> a -> b) -> [a] -> [b]+{-# INLINE imap #-}+imap f = zipWith f [0..]+ enumFromTo_Int :: Int -> Int -> [Int] {-# INLINE enumFromTo_Int #-} enumFromTo_Int = enumFromTo +cons :: a -> [a] -> [a]+{-# INLINE cons #-}+cons = (:)++index :: [a] -> Int -> a+{-# INLINE index #-}+index = (!!)++append :: [a] -> [a] -> [a]+{-# INLINE append #-}+append = (++)++slice :: [a] -> Int -> Int -> [a]+{-# INLINE slice #-}+slice xs i n = take n (drop i xs)++prescanl' :: (a -> b -> a) -> a -> [b] -> [a]+{-# INLINE prescanl' #-}+prescanl' f z xs = init (scanl f z xs)++prescanr' :: (a -> b -> b) -> b -> [a] -> [b]+{-# INLINE prescanr' #-}+prescanr' f z xs = tail (scanr f z xs)++backpermute = Unsupported+update = Unsupported+update_ = Unsupported++minIndex = Unsupported+maxIndex = Unsupported++unstablePartition :: (a -> Bool) -> [a] -> ([a],[a])+{-# INLINE unstablePartition #-}+unstablePartition = partition+ pair :: a -> b -> (a,b) pair = (,)++from2 :: (a,b) -> (a,b)+from2 = id++triple :: a -> b -> c -> (a,b,c)+triple = (,,)++from3 :: (a,b,c) -> (a,b,c)+from3 = id
NoSlow/Backend/StorableVector.hs view
@@ -1,40 +1,82 @@ {-# LANGUAGE TypeFamilies #-} module NoSlow.Backend.StorableVector ( module Data.StorableVector,- sum, enumFromTo_Int, zip,- pair, fst, snd+ imap, slice, sum, and, enumFromTo_Int, prescanl', prescanr',+ backpermute, update, update_,+ minIndex, maxIndex, unstablePartition,+ zip, zip3, unzip, pair, from2, fst, snd, triple, from3 ) where import NoSlow.Util.Computation import NoSlow.Util.Base ( Unsupported(..) ) import qualified Data.StorableVector as V-import Data.StorableVector hiding ( zip )+import Data.StorableVector hiding ( zip, unzip ) import Foreign ( Storable )-import Prelude hiding ( sum, fst, snd, zip )+import Prelude hiding ( sum, and, fst, snd, zip, zip3, unzip ) instance DeepSeq (V.Vector a) instance (TestData a, Storable a) => TestData (V.Vector a) where- testData n = V.pack (testData n)+ testData = testList -instance Computation (V.Vector a) where- type Arg (V.Vector a) = Nil- type Res (V.Vector a) = V.Vector a- apply x _ = x+instance Storable a => ListLike V.Vector a where+ fromList = V.pack +imap :: (Storable a, Storable b) => (Int -> a -> b) -> V.Vector a -> V.Vector b+{-# INLINE imap #-}+imap = V.mapIndexed++slice :: Storable a => V.Vector a -> Int -> Int -> V.Vector a+{-# INLINE slice #-}+slice xs i n = V.take n (V.drop i xs)+ sum :: (Num a, Storable a) => V.Vector a -> a {-# INLINE sum #-} sum xs = V.foldl' (+) 0 xs +and :: V.Vector Bool -> Bool+{-# INLINE and #-}+and xs = V.foldl' (&&) True 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) +prescanl' :: (Storable a, Storable b)+ => (a -> b -> a) -> a -> V.Vector b -> V.Vector a+{-# INLINE prescanl' #-}+prescanl' f z v = V.init (V.scanl f z v)++prescanr' :: (Storable a, Storable b)+ => (a -> b -> b) -> b -> V.Vector a -> V.Vector b+{-# INLINE prescanr' #-}+prescanr' f z v = V.tail (V.scanr f z v)++backpermute :: Storable a => V.Vector a -> V.Vector Int -> V.Vector a+{-# INLINE backpermute #-}+backpermute xs is = xs `seq` V.map (V.index xs) is++update = Unsupported+update_ = Unsupported++minIndex = Unsupported+maxIndex = Unsupported++unstablePartition :: Storable a => (a -> Bool) -> V.Vector a+ -> (V.Vector a, V.Vector a)+{-# INLINE unstablePartition #-}+unstablePartition f xs = (V.filter f xs, V.filter (not . f) xs)+ zip = Unsupported+zip3 = Unsupported+unzip = Unsupported pair = Unsupported+from2 = Unsupported fst = Unsupported snd = Unsupported+triple = Unsupported+from3 = Unsupported
NoSlow/Backend/TH.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE TemplateHaskell, PatternGuards, CPP #-} module NoSlow.Backend.TH ( Spec(..), specialise, calls ) where -import NoSlow.Util.Base ( named, Unsupported(..) )+import NoSlow.Util.Base ( named, Unsupported(..), noinline )+import NoSlow.Util.Computation ( deepSeq ) import qualified NoSlow.Backend.Interface as I import Language.Haskell.TH@@ -76,6 +77,14 @@ go _ _ = Nothing #endif +funTyArity :: Type -> Int+funTyArity (ForallT _ _ ty) = funTyArity ty+#if __GLASGOW_HASKELL__ > 610+funTyArity (SigT ty _) = funTyArity ty+#endif+funTyArity (AppT (AppT ArrowT _) ty) = funTyArity ty + 1+funTyArity _ = 0+ #if __GLASGOW_HASKELL__ <= 610 type TyVarBndr = Name #endif@@ -269,9 +278,15 @@ specialiseBody :: Body -> SM Body specialiseBody (NormalB exp)- = liftM NormalB- $ specialiseExp (snd $ removeNamed exp)+ = liftM NormalB $ specialiseExp (snd $ removeNamed exp)+specialiseBody (GuardedB ps)+ = liftM GuardedB $ mapM spec ps+ where+ spec (guard, exp) = liftM2 (,) (specialiseGuard guard) (specialiseExp exp) +specialiseGuard :: Guard -> SM Guard+specialiseGuard (NormalG exp) = liftM NormalG $ specialiseExp exp+ specialiseExp :: Exp -> SM Exp specialiseExp (VarE v) | Just mod <- nameModule v@@ -301,7 +316,8 @@ = liftM2 LetE (mapM specialiseDec decs) (specialiseExp e) -specialiseExp (CaseE _ _) = error "specialiseExp: case"+specialiseExp (CaseE exp ms)+ = liftM2 CaseE (specialiseExp exp) (mapM specialiseMatch ms) specialiseExp (DoE _) = error "specialiseExp: do" specialiseExp (CompE _) = error "specialiseExp: comp" specialiseExp (ArithSeqE _) = error "specialiseExp: seq"@@ -316,23 +332,44 @@ specialiseExp e = return e +specialiseMatch :: Match -> SM Match+specialiseMatch (Match pat body decs)+ = liftM2 (Match pat) (specialiseBody body) (mapM specialiseDec decs)+ 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]+ cs <- mapM (call env) [(name, ty) | SigD name ty <- decs] return $ ListE [c | Just c <- cs] where- call env name+ call env (name, ty) = do ok <- isSupported name' return $ if ok- then Just (VarE fn `AppE` LitE (StringL tag) `AppE` VarE name')+ then Just (VarE fn `AppE` LitE (StringL tag)+ `AppE` invoke (VarE name')) else Nothing where name' = qualify mod name tag = M.findWithDefault (nameBase name) (nameBase name) env++ arity = funTyArity ty - 1++ invoke e = LamE [VarP t, pat]+ $ VarE 'deepSeq+ `AppE` foldl AppE (e' `AppE` VarE t) (map VarE vs)+ `AppE` ConE '()+ where+ e' = VarE 'noinline `AppE` e+ t = mkName "tag"+ + vs = take arity [mkName [c] | c <- ['a' .. ]]++ pat | arity == 0 = ConP '() []+ | arity == 1 = VarP $ head vs+ | otherwise = TupP $ map VarP vs qualify :: String -> Name -> Name qualify mod name = mkName $ mod ++ '.' : nameBase name
NoSlow/Backend/Uvector.hs view
@@ -2,26 +2,36 @@ module NoSlow.Backend.Uvector ( UA, UArr, - length, replicate, map, zip, zipWith, sum, enumFromTo_Int, filter,- pair, fst, snd+ null, length, replicate, cons, head, tail, map, imap,+ zip, zip3, zipWith, unzip,+ sum, and, prescanl',+ enumFromTo_Int,+ filter, index, append, take, drop, slice, backpermute, update, update_,+ minIndex, maxIndex, unstablePartition,+ prescanr',+ pair, from2, fst, snd, triple, from3 ) where import NoSlow.Util.Computation+import NoSlow.Util.Base ( Unsupported(..) ) import Data.Array.Vector+import qualified Data.Array.Vector.UArr as UArr ( indexU ) import qualified Prelude-import Prelude ( Int, Num, Bool )+import Prelude ( Ord(..), Num, Int, Bool, (.), ($), fmap, seq, flip, not ) instance DeepSeq (UArr a) instance (TestData a, UA a) => TestData (UArr a) where- testData n = toU (testData n)+ testData = testList -instance Computation (UArr a) where- type Arg (UArr a) = Nil- type Res (UArr a) = UArr a- apply x _ = x+instance UA a => ListLike UArr a where+ fromList = toU +null :: UA a => UArr a -> Bool+{-# INLINE null #-}+null = nullU+ length :: UA a => UArr a -> Int {-# INLINE length #-} length = lengthU@@ -30,22 +40,56 @@ {-# INLINE replicate #-} replicate = replicateU +cons :: UA a => a -> UArr a -> UArr a+{-# INLINE cons #-}+cons = consU++head :: UA a => UArr a -> a+{-# INLINE head #-}+head = headU++tail :: UA a => UArr a -> UArr a+{-# INLINE tail #-}+tail = tailU+ map :: (UA a, UA b) => (a -> b) -> UArr a -> UArr b {-# INLINE map #-} map = mapU +imap :: (UA a, UA b) => (Int -> a -> b) -> UArr a -> UArr b+{-# INLINE imap #-}+imap f xs = mapU (uncurryS f) (indexedU xs)+ zip :: (UA a, UA b) => UArr a -> UArr b -> UArr (a :*: b) {-# INLINE zip #-} zip = zipU +zip3 :: (UA a, UA b, UA c) => UArr a -> UArr b -> UArr c -> UArr (a :*: b :*: c)+{-# INLINE zip3 #-}+zip3 = zip3U+ zipWith :: (UA a, UA b, UA c) => (a -> b -> c) -> UArr a -> UArr b -> UArr c {-# INLINE zipWith #-} zipWith = zipWithU +unzip :: (UA a, UA b) => UArr (a :*: b) -> UArr a :*: UArr b+{-# INLINE unzip #-}+unzip = unzipU+ sum :: (Num a, UA a) => UArr a -> a {-# INLINE sum #-} sum = sumU +and :: UArr Bool -> Bool+{-# INLINE and #-}+and = andU++prescanl' :: (UA a, UA b) => (a -> b -> a) -> a -> UArr b -> UArr a+{-# INLINE prescanl' #-}+prescanl' = scanlU++prescanr' = Unsupported+ enumFromTo_Int :: Int -> Int -> UArr Int {-# INLINE enumFromTo_Int #-} enumFromTo_Int = enumFromToU@@ -54,10 +98,54 @@ {-# INLINE filter #-} filter = filterU +index :: UA a => UArr a -> Int -> a+{-# INLINE index #-}+index = indexU++append :: UA a => UArr a -> UArr a -> UArr a+{-# INLINE append #-}+append = appendU++take :: UA a => Int -> UArr a -> UArr a+{-# INLINE take #-}+take = takeU++drop :: UA a => Int -> UArr a -> UArr a+{-# INLINE drop #-}+drop = dropU++slice :: UA a => UArr a -> Int -> Int -> UArr a+{-# INLINE slice #-}+slice = sliceU++-- Sigh! Where did my backpermute go?+backpermute :: UA a => UArr a -> UArr Int -> UArr a+{-# INLINE backpermute #-}+backpermute xs is = xs `seq` mapU (UArr.indexU xs) is++update = Unsupported+update_ = Unsupported++minIndex :: (Ord e, UA e) => UArr e -> Int+{-# INLINE minIndex #-}+minIndex = fstS . minimumByU (\p q -> compare (sndS p) (sndS q)) . indexedU++maxIndex :: (Ord e, UA e) => UArr e -> Int+{-# INLINE maxIndex #-}+maxIndex = fstS . maximumByU (\p q -> compare (sndS p) (sndS q)) . indexedU++unstablePartition :: UA a => (a -> Bool) -> UArr a -> (UArr a, UArr a)+{-# INLINE unstablePartition #-}+unstablePartition f xs = (filterU f xs, filterU (not . f) xs)+ pair :: a -> b -> a :*: b {-# INLINE pair #-} pair = (:*:) +from2 :: a :*: b -> (a,b)+{-# INLINE from2 #-}+from2 (a :*: b) = (a,b)+ fst :: a :*: b -> a {-# INLINE fst #-} fst = fstS@@ -65,4 +153,12 @@ snd :: a :*: b -> b {-# INLINE snd #-} snd = sndS++triple :: a -> b -> c -> a :*: b :*: c+{-# INLINE triple #-}+triple a b c = a :*: b :*: c++from3 :: a :*: b :*: c -> (a,b,c)+{-# INLINE from3 #-}+from3 (a :*: b :*: c) = (a,b,c)
NoSlow/Backend/Vector.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, CPP #-} module NoSlow.Backend.Vector ( module Data.Vector, - enumFromTo_Int,- pair, fst, snd+ enumFromTo_Int, index, append,+ pair, from2, fst, snd, triple, from3 ) where import NoSlow.Util.Computation@@ -12,21 +12,45 @@ import Data.Vector instance DeepSeq a => DeepSeq (V.Vector a) where- deepSeq xs b = V.foldr deepSeq b xs+ {-# INLINE deepSeq #-}+ deepSeq xs b = xs `seq` n `seq` go 0+ where+ n = V.length xs + go i | i < n = (xs V.! i) `deepSeq` go (i+1)+ | otherwise = b+ instance TestData a => TestData (V.Vector a) where- testData n = V.fromList (testData n)+ testData = testList -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+instance ListLike V.Vector a where+ fromList = V.fromList enumFromTo_Int :: Int -> Int -> V.Vector Int {-# INLINE enumFromTo_Int #-} enumFromTo_Int = V.enumFromTo +index :: V.Vector a -> Int -> a+{-# INLINE index #-}+index = (V.!)++append :: V.Vector a -> V.Vector a -> V.Vector a+{-# INLINE append #-}+append = (V.++)+ pair :: a -> b -> (a,b) {-# INLINE pair #-} pair = (,)++from2 :: (a,b) -> (a,b)+{-# INLINE from2 #-}+from2 = id++triple :: a -> b -> c -> (a,b,c)+{-# INLINE triple #-}+triple = (,,)++from3 :: (a,b,c) -> (a,b,c)+{-# INLINE from3 #-}+from3 = id
NoSlow/Backend/Vector/Primitive.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, CPP #-} module NoSlow.Backend.Vector.Primitive ( module Data.Vector.Primitive, - enumFromTo_Int, zip,- pair, fst, snd+ enumFromTo_Int, index, append, update, and,+ zip, zip3, unzip, pair, from2, fst, snd, triple, from3 ) where import NoSlow.Util.Computation@@ -11,24 +11,38 @@ import qualified Data.Vector.Primitive as V import Data.Vector.Primitive -import Prelude hiding ( fst, snd, zip )+import Prelude hiding ( and, fst, snd, zip, zip3, unzip ) instance DeepSeq (V.Vector a) instance (TestData a, V.Prim a) => TestData (V.Vector a) where- testData n = V.fromList (testData n)+ testData = testList -instance Computation (V.Vector a) where- type Arg (V.Vector a) = Nil- type Res (V.Vector a) = V.Vector a- apply x _ = x+instance V.Prim a => ListLike V.Vector a where+ fromList = V.fromList enumFromTo_Int :: Int -> Int -> V.Vector Int {-# INLINE enumFromTo_Int #-} enumFromTo_Int = V.enumFromTo +index :: V.Prim a => V.Vector a -> Int -> a+{-# INLINE index #-}+index = (V.!)++append :: V.Prim a => V.Vector a -> V.Vector a -> V.Vector a+{-# INLINE append #-}+append = (V.++)++and = Unsupported+update = Unsupported+ zip = Unsupported+zip3 = Unsupported+unzip = Unsupported pair = Unsupported+from2 = Unsupported fst = Unsupported snd = Unsupported+triple = Unsupported+from3 = Unsupported
NoSlow/Backend/Vector/Storable.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, CPP #-} module NoSlow.Backend.Vector.Storable ( module Data.Vector.Storable, - enumFromTo_Int, zip,- pair, fst, snd+ enumFromTo_Int, index, append, update,+ zip, zip3, unzip, pair, from2, fst, snd, triple, from3 ) where import NoSlow.Util.Computation@@ -11,24 +11,37 @@ import qualified Data.Vector.Storable as V import Data.Vector.Storable -import Prelude hiding ( fst, snd, zip )+import Prelude hiding ( fst, snd, zip, zip3, unzip ) instance DeepSeq (V.Vector a) instance (TestData a, V.Storable a) => TestData (V.Vector a) where- testData n = V.fromList (testData n)+ testData = testList -instance Computation (V.Vector a) where- type Arg (V.Vector a) = Nil- type Res (V.Vector a) = V.Vector a- apply x _ = x+instance V.Storable a => ListLike V.Vector a where+ fromList = V.fromList enumFromTo_Int :: Int -> Int -> V.Vector Int {-# INLINE enumFromTo_Int #-} enumFromTo_Int = V.enumFromTo +index :: V.Storable a => V.Vector a -> Int -> a+{-# INLINE index #-}+index = (V.!)++append :: V.Storable a => V.Vector a -> V.Vector a -> V.Vector a+{-# INLINE append #-}+append = (V.++)++update = Unsupported+ zip = Unsupported+zip3 = Unsupported+unzip = Unsupported pair = Unsupported+from2 = Unsupported fst = Unsupported snd = Unsupported+triple = Unsupported+from3 = Unsupported
+ NoSlow/Backend/Vector/Unboxed.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies, CPP #-}+module NoSlow.Backend.Vector.Unboxed (+ module Data.Vector.Unboxed,++ enumFromTo_Int, index, append,+ pair, from2, fst, snd, triple, from3+) where++import NoSlow.Util.Computation+import qualified Data.Vector.Unboxed as V+import Data.Vector.Unboxed++import Prelude++instance DeepSeq (V.Vector a)++instance (TestData a, V.Unbox a) => TestData (V.Vector a) where+ testData = testList++instance V.Unbox a => ListLike V.Vector a where+ fromList = V.fromList++enumFromTo_Int :: Int -> Int -> V.Vector Int+{-# INLINE enumFromTo_Int #-}+enumFromTo_Int = V.enumFromTo++index :: V.Unbox a => V.Vector a -> Int -> a+{-# INLINE index #-}+index = (V.!)++append :: V.Unbox a => V.Vector a -> V.Vector a -> V.Vector a+{-# INLINE append #-}+append = (V.++)++pair :: a -> b -> (a,b)+{-# INLINE pair #-}+pair = (,)++from2 :: (a,b) -> (a,b)+{-# INLINE from2 #-}+from2 = id++triple :: a -> b -> c -> (a,b,c)+{-# INLINE triple #-}+triple = (,,)++from3 :: (a,b,c) -> (a,b,c)+{-# INLINE from3 #-}+from3 = id+
NoSlow/Main.hs view
@@ -4,10 +4,26 @@ import NoSlow.Main.TH import NoSlow.Main.Tree import NoSlow.Main.Util ( (>++<) )+import NoSlow.Util.Base ( Sort(..) )+import NoSlow.Util.Tag+import qualified NoSlow.Util.Opts as O -import Criterion.Main+import Criterion import Criterion.Config+import Criterion.Monad ( withConfig )+import Criterion.Environment ( measureEnvironment ) +import System.Console.GetOpt+import System.Environment ( getArgs, getProgName )+import System.Exit ( ExitCode(..) )+import Data.Monoid ( Last(..) )+import Data.Version ( showVersion )++import Paths_NoSlow ( version )++import qualified NoSlow.Micro.Kernels as Micro+import qualified NoSlow.Mini.Kernels as Mini+ import qualified NoSlow.Micro.List import qualified NoSlow.Micro.List.Double @@ -17,6 +33,16 @@ #endif #ifdef USE_VECTOR+import qualified NoSlow.Micro.Vector.Unsafe.Unboxed+import qualified NoSlow.Micro.Vector.Unsafe.Unboxed.Double+import qualified NoSlow.Micro.Vector.Unsafe.Primitive+import qualified NoSlow.Micro.Vector.Unsafe.Primitive.Double+import qualified NoSlow.Micro.Vector.Unsafe.Storable+import qualified NoSlow.Micro.Vector.Unsafe.Storable.Double+import qualified NoSlow.Micro.Vector.Unsafe.Boxed+import qualified NoSlow.Micro.Vector.Unsafe.Boxed.Double+import qualified NoSlow.Micro.Vector.Unboxed+import qualified NoSlow.Micro.Vector.Unboxed.Double import qualified NoSlow.Micro.Vector.Primitive import qualified NoSlow.Micro.Vector.Primitive.Double import qualified NoSlow.Micro.Vector.Storable@@ -35,9 +61,154 @@ import qualified NoSlow.Micro.StorableVector.Double #endif -all_kernels = $(benchtrees Poly [t|Double|] kernel_tree)- >++< $(benchtrees Mono [t|Double|] kernel_tree)+import qualified NoSlow.Mini.List -main = defaultMainWith (defaultConfig { cfgPerformGC = ljust True })- (all_kernels 10000)+#ifdef USE_DPH_PRIM_SEQ+import qualified NoSlow.Mini.DPH.Prim.Seq+#endif++#ifdef USE_VECTOR+import qualified NoSlow.Mini.Vector.Unsafe.Unboxed+import qualified NoSlow.Mini.Vector.Unsafe.Primitive+import qualified NoSlow.Mini.Vector.Unsafe.Storable+import qualified NoSlow.Mini.Vector.Unsafe.Boxed+import qualified NoSlow.Mini.Vector.Unboxed+import qualified NoSlow.Mini.Vector.Primitive+import qualified NoSlow.Mini.Vector.Storable+import qualified NoSlow.Mini.Vector.Boxed+#endif++#ifdef USE_UVECTOR+import qualified NoSlow.Mini.Uvector+#endif++#ifdef USE_STORABLEVECTOR+import qualified NoSlow.Mini.StorableVector+#endif++all_kernels = $(benchtrees "*Double" Generic [t|Double|] Micro.kernels micro_tree)+ >++< $(benchtrees "Double" Specialised [t|Double|] Micro.kernels micro_tree)++ >++< $(benchtrees "mini" Generic [t|()|] Mini.kernels mini_tree)++main = do+ opts <- O.parseAll defaultOpts allOptions =<< getArgs+ writeFile (optOutputFile opts) "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB\n"+ withConfig (optsToConfig opts) $+ do+ env <- measureEnvironment+ let shouldRun s = case reads s of+ [(tag, "")] -> optShouldRun opts tag+ runAndAnalyse shouldRun env+ $ bgroup ""+ $ all_kernels 10000++data Opts = Opts {+ optConfInterval :: Double+ , optPerformGC :: Bool+ , optResamples :: Int+ , optSamples :: Int+ , optVerbosity :: Verbosity+ , optOutputFile :: String+ , optShouldRun :: Tag -> Bool+ }++defaultOpts :: Opts+defaultOpts = Opts {+ optConfInterval = from_config cfgConfInterval+ , optPerformGC = True+ , optResamples = from_config cfgResamples+ , optSamples = from_config cfgSamples+ , optVerbosity = Normal+ , optOutputFile = "noslow.log"+ , optShouldRun = const True+ }+ where+ from_config :: (Config -> Last a) -> a+ from_config f = case f defaultConfig of+ Last (Just x) -> x++addFilter :: (Tag -> Bool) -> Opts -> Opts+addFilter f opts@(Opts { optShouldRun = p })+ = opts { optShouldRun = \t -> p t && f t }++optsToConfig :: Opts -> Config+optsToConfig opts = defaultConfig {+ cfgConfInterval = ljust $ optConfInterval opts+ , cfgPerformGC = ljust $ optPerformGC opts+ , cfgResamples = ljust $ optResamples opts+ , cfgSamples = ljust $ optSamples opts+ , cfgVerbosity = ljust $ optVerbosity opts+ , cfgSummaryFile = ljust $ optOutputFile opts+ , cfgBanner = ljust $ showVersion version+ }++type OptM = O.OptM Opts++allOptions :: [OptDescr OptM]+allOptions = [+ Option ['b'] ["bench"]+ (O.selArg O.matchName addFilter "LIST")+ "only run some benchmarks"+ , Option ['l'] ["lib"]+ (O.selArg O.matchLib addFilter "LIST")+ "only benchmark the specified libraries"+ , Option ['g'] ["group"]+ (O.selArg O.matchGroup addFilter "LIST")+ "only run benchmarks from the specified benchmark group"+ , Option ['o'] ["output"]+ (O.reqArg (\s opt -> opt { optOutputFile = s }) "FILE")+ "store benchmark results in this file"+ , Option [] ["gc"]+ (O.noArg $ \opt -> opt { optPerformGC = True })+ "collect garbage between iterations"+ , Option [] ["no-gc"]+ (O.noArg $ \opt -> opt { optPerformGC = False })+ "do not collect garbage between iterations"+ , Option ['I'] ["ci"]+ (O.readArg "confidence interval"+ (\(CI ci) -> ci > 0 && ci < 1)+ (\(CI ci) opt -> opt { optConfInterval = ci }) "CI")+ "bootstrap confidence interval"+ , Option ['r'] ["resamples"]+ (O.readArg "resample count" (>0)+ (\n opt -> opt { optResamples = n }) "N")+ "number of bootstrap resamples to perform"+ , Option ['s'] ["samples"]+ (O.readArg "sample count" (>0)+ (\n opt -> opt { optSamples = n }) "N")+ "number of samples to collect"+ , Option ['v'] ["verbose"]+ (O.noArg $ \opt -> opt { optVerbosity = Verbose })+ "print more output"+ , Option ['q'] ["quiet"]+ (O.noArg $ \opt -> opt { optVerbosity = Quiet })+ "print less output"+ , Option ['V'] ["version"]+ (O.helpArg printVersion)+ "output version, then exit"+ , Option ['h','?'] ["help"]+ (O.helpArg printUsage)+ "output help"+ ]++newtype CI = CI Double++instance Read CI where+ readsPrec n s = map upd (readsPrec n s')+ where+ upd (d,'%':t) = (CI (d/100),t)+ upd (d,t) = (CI d,t)++ s' = case s of+ '.' : _ -> '0':s+ _ -> s++printVersion :: IO ()+printVersion = putStrLn (showVersion version)++printUsage :: IO ()+printUsage = do+ p <- getProgName+ putStrLn (usageInfo ("Usage: " ++ p ++ " [OPTIONS]") allOptions)
NoSlow/Main/TH.hs view
@@ -9,37 +9,31 @@ import Language.Haskell.TH -data Sort = Poly | Mono--benchtrees :: Sort -> TypeQ -> [KTree] -> ExpQ-benchtrees sort tyq ts+benchtrees :: String -> Sort -> TypeQ -> Q [Dec] -> [KTree] -> ExpQ+benchtrees grp sort tyq ks ts = do ty <- tyq- varE 'klist `appE` listE (map (benchtree sort ty) ts)+ varE 'klist `appE` listE (map (benchtree grp sort ty ks) 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)+benchtree :: String -> Sort -> Type -> Q [Dec] -> KTree -> ExpQ+benchtree grp sort ty ks (KGroup s ts)+ = mk_kgroup s (map (benchtree grp sort ty ks) ts)+benchtree grp sort ty@(ConT c) ks (KModule s gmod) = do- TyConI (TySynD t _ _) <- reify $ mkName $ poly_mod ++ ".Spec_Vector"-- let tag = case sort of- Poly -> '*' : nameBase c- Mono -> nameBase c-- real_mod = case sort of- Poly -> poly_mod- Mono -> poly_mod ++ '.' : nameBase c+ TyConI (TySynD t _ _) <- reify $ mkName $ gmod ++ ".Spec_Vector" - vec_ty = conT t `appT` return ty+ let 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]+ mk_kgroup s [mk_kernels 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_kernels ty mod = varE 'kernels `appE` litE (StringL grp)+ `appE` ty+ `appE` calls 'kernel mod ks++ real_mod = case sort of+ Generic -> gmod+ Specialised -> gmod ++ '.' : nameBase c mk_kgroup :: String -> [ExpQ] -> ExpQ mk_kgroup s exps = varE 'kgroup `appE` litE (StringL s) `appE` listE exps
NoSlow/Main/Tree.hs view
@@ -4,29 +4,56 @@ import NoSlow.Main.Util -kernel_tree- = [ KModule "list" "NoSlow.Micro.List"+micro_tree = map (qualify "NoSlow.Micro") tree+mini_tree = map (qualify "NoSlow.Mini") tree +tree+ = concat [+ list_tree+ , dph_prim_tree+ , vector_tree+ , uvector_tree+ , storablevector_tree+ ]++list_tree =+ [ KModule "list" "List" ]++dph_prim_tree = [ #ifdef USE_DPH_PRIM_SEQ- , KGroup "dph-prim" [- KModule "seq" "NoSlow.Micro.DPH.Prim.Seq"- ]+ KGroup "dph-prim" [+ KModule "seq" "DPH.Prim.Seq"+ ] #endif+ ] +vector_tree = [ #ifdef USE_VECTOR- , KGroup "vector" [- KModule "Primitive" "NoSlow.Micro.Vector.Primitive"- , KModule "Storable" "NoSlow.Micro.Vector.Storable"- , KModule "boxed" "NoSlow.Micro.Vector.Boxed"- ]+ KGroup "vector" [+ KModule "Primitive" "Vector.Primitive"+ , KModule "Storable" "Vector.Storable"+ , KModule "Unboxed" "Vector.Unboxed"+ , KModule "boxed" "Vector.Boxed"+ ],++ KGroup "vector-unsafe" [+ KModule "Primitive" "Vector.Unsafe.Primitive"+ , KModule "Storable" "Vector.Unsafe.Storable"+ , KModule "Unboxed" "Vector.Unsafe.Unboxed"+ , KModule "boxed" "Vector.Unsafe.Boxed"+ ] #endif+ ] +uvector_tree = [ #ifdef USE_UVECTOR- , KModule "uvector" "NoSlow.Micro.Uvector"+ KModule "uvector" "Uvector" #endif+ ] +storablevector_tree = [ #ifdef USE_STORABLEVECTOR- , KModule "storablevector" "NoSlow.Micro.StorableVector"+ KModule "storablevector" "StorableVector" #endif- ]+ ]
NoSlow/Main/Util.hs view
@@ -1,16 +1,20 @@-module NoSlow.Main.Util ( kernel, kernels, kgroup, klist, KTree(..), (>++<) )-where+module NoSlow.Main.Util (+ kernel, kernels, kgroup, klist, KTree(..), (>++<), qualify+) where import NoSlow.Util.Base import NoSlow.Util.Computation -import Criterion.Main ( Benchmark, B(..), bench, bgroup ) +import Criterion.Main ( Benchmark, whnf, 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` ()+-- NOTE: The deepSeq on the result is introduced by the TH code. GHC 6.12 (and+-- sometimes 6.13) won't optimise it otherwise.+-- See http://hackage.haskell.org/trac/ghc/ticket/3772+kernel :: TestData arg+ => String -> (Ty a -> arg -> ()) -> Ty a -> Int -> Benchmark+{-# NOINLINE kernel #-}+kernel s f = \t n -> let x = generateData n+ in x `deepSeq` bench s (whnf (f t) x) kernels :: String -> Ty a -> [Ty a -> Int -> Benchmark] -> Int -> Benchmark kernels s t bs n = bgroup s [b t n | b <- bs]@@ -27,4 +31,8 @@ infixr 5 >++< (>++<) :: (Int -> [Benchmark]) -> (Int -> [Benchmark]) -> Int -> [Benchmark] (>++<) f g n = f n ++ g n++qualify :: String -> KTree -> KTree+qualify p (KGroup s ts) = KGroup s (map (qualify p) ts)+qualify p (KModule s m) = KModule s (p ++ '.' : m)
NoSlow/Micro/Kernels.hs view
@@ -1,90 +1,72 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, FlexibleContexts #-} module NoSlow.Micro.Kernels ( kernels ) where import qualified NoSlow.Backend.Interface as I import NoSlow.Util.Base+import NoSlow.Util.Computation ( Len(..), WithSqrtLen(..), Sorted(..),+ ParenTree(..), Edges(..) ) +import Data.Bits+ 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+ -- Scale a vector by a constant --- -- 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+ -- NOTE: we do not want to measure LiberateCase here so we explicitly unbox+ -- x+ scale :: (Num a, I.Vector v a) => Ty (v a) -> v a -> a -> v a+ scale _ as x = seq x $+ I.map (x*) as - -- Add a number to every element (version 2)+ -- Scale a vector by a constant (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)+ -- similar to splus.+ scale_r :: (Num a, I.Vector v a) => Ty (v a) -> v a -> a -> v a+ scale_r _ as 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+ splus4 _ as x = seq 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+ plus _ as bs = 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)+ plus_zip _ as bs = I.map (\p -> I.fst p + I.snd p) (I.zip as bs) - -- x should only be inspected once outside the loop+ -- Standard axpy benchmark 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" $+ axpy _ x as bs = seq x $ 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)+ mpp _ as bs cs ds = 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))+ mpp_zip _ as bs cs ds = 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)" $+ mspsp _ x as y bs = seq x $ seq y $ 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)" $+ mspsp_r _ x as y bs = I.zipWith (*) (I.zipWith (+) (I.replicate (I.length as) x) as) (I.zipWith (+) (I.replicate (I.length bs) y) bs) @@ -94,37 +76,24 @@ -- 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+ filterout _ as = 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+ filterout_r _ (Len n) = 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+ filterin _ as = 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)+ filterin_r _ (Len n) = I.filter (==0) $ I.replicate n 0 - -- 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)+ => Ty (v a) -> a -> v a -> v a -> v a+ filter_zip _ x as bs = seq x $+ I.filter (<x) (I.zipWith (+) as bs) filter_evens :: I.Vector v a => Ty (v a) -> Len -> v a -> v a filter_evens _ (Len n) as =@@ -132,31 +101,35 @@ $ I.filter (even . I.fst) $ I.zip (I.enumFromTo_Int 0 (n-1)) as + find_indices :: (Eq a, I.Vector v a) => Ty (v a) -> a -> v a -> v Int+ find_indices _ x as = seq x+ $ I.map I.fst+ $ I.filter (\t -> x == I.snd t)+ $ I.zip (I.enumFromTo_Int 0 (I.length as - 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 _ as bs = 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))+ dotp_zip _ as bs = 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+ sumn ty (Len 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)" $+ sumsq_map ty (Len n) = 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)" $+ sumsq_zip ty (Len n) = let as = I.map fromIntegral (I.enumFromTo_Int 1 n) `ofType` ty in I.sum $ I.zipWith (*) as as@@ -167,6 +140,86 @@ $ I.map I.snd $ I.filter (even . I.fst) $ I.zip (I.enumFromTo_Int 0 (n-1)) as++ count_sum :: (Eq a, I.Vector v a) => Ty (v a) -> a -> v a -> Int+ count_sum _ x as = seq x $ I.sum $ I.map (\y -> if x == y then 1 else 0) as++ count_filter :: (Eq a, I.Vector v a) => Ty (v a) -> a -> v a -> Int+ count_filter _ x as = seq x $ I.length $ I.filter (x==) as++ + {-+ -- -----+ -- Folds+ -- -----++ min_index :: (Ord a, I.Vector v a) => Ty (v a) -> v a -> Int+ min_index _ as = I.foldl1' (\(i,x) (j,y) -> if i <= j then (i,x) else (j,y))+ $ I.zip (I.enumFromTo 0 (I.length as - 1)) as+ -}++ -- -----+ -- Scans+ -- -----++ scan_replicate :: (Num a, I.Vector v a) => Ty (v a) -> Len -> v a+ scan_replicate _ (Len n) = I.prescanl' (+) 0 (I.replicate n 1)++ sumn_scan :: (Num a, I.Vector v a) => Ty (v a) -> Len -> a+ sumn_scan ty (Len n) = I.sum (I.prescanl' (+) 0 (I.replicate n 1 `ofType` ty))++ -- --------+ -- Permutes+ -- --------++ -- Compare to odds_backpermute; the conditional in n might interfere+ -- with fusion+ evens_backpermute :: I.Vector v a => Ty (v a) -> v a -> v a+ evens_backpermute _ as+ = I.backpermute as $ I.map (*2) $ I.enumFromTo_Int 0 (n-1)+ where+ m = I.length as+ n = if odd m then m `div` 2 + 1 else m `div` 2++ -- Compare to evens_backpermute+ odds_backpermute :: I.Vector v a => Ty (v a) -> v a -> v a+ odds_backpermute _ as+ = I.backpermute as $ I.map (\i -> i*2+1)+ $ I.enumFromTo_Int 0 (I.length as `div` 2 - 1)++ interleave :: I.Vector v a => Ty (v a) -> v a -> v a -> v a+ interleave _ as bs+ = I.backpermute (I.append as bs)+ $ I.map (\i -> if even i then i `div` 2 else i `div` 2 + m)+ $ I.enumFromTo_Int 0 (m+n-1)+ where+ m = I.length as+ n = I.length bs++ -- ----------+ -- Algorithms+ -- ----------++ sorted_rank :: (Ord a, I.Vector v a) => Ty (v a) -> a -> Sorted v a -> Int+ sorted_rank _ x (Sorted xs) = go 0 xs+ where+ go k xs | n == 0 = k+ | x <= I.index xs i = go k (I.take i xs)+ | otherwise = go (k+i+1) (I.drop (i+1) xs)+ where+ n = I.length xs+ i = n `div` 2++ qsort :: (Ord a, I.Vector v a) => Ty (v a) -> v a -> v a+ qsort ty xs+ | n < 2 = xs+ | otherwise = I.append (qsort ty lts) (I.cons x (qsort ty geqs))+ where+ n = I.length xs+ x = I.head xs+ lts = x `seq` I.filter (<x) (I.tail xs)+ geqs = x `seq` I.filter (>=x) (I.tail xs)+ -- (lts, geqs) = x `seq` I.unstablePartition (<x) (I.tail xs) |]
+ NoSlow/Micro/Vector/Unboxed.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Unboxed+where++import qualified NoSlow.Backend.Vector.Unboxed as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++type Spec_Vector = Impl.Vector+type Spec_Elem a = a+class Impl.Unbox a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Micro/Vector/Unboxed/Double.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Unboxed.Double+where++import qualified NoSlow.Backend.Vector.Unboxed as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = Double+class Impl.Unbox a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Micro/Vector/Unsafe/Boxed.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Unsafe.Boxed+where++import qualified NoSlow.Backend.Vector.Unsafe as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++type Spec_Vector = Impl.Vector+type Spec_Elem a = a+class Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Micro/Vector/Unsafe/Boxed/Double.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Unsafe.Boxed.Double+where++import qualified NoSlow.Backend.Vector.Unsafe as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = Double+class Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Micro/Vector/Unsafe/Primitive.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Unsafe.Primitive+where++import qualified NoSlow.Backend.Vector.Unsafe.Primitive as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++type Spec_Vector = Impl.Vector+type Spec_Elem a = a+class Impl.Prim a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Micro/Vector/Unsafe/Primitive/Double.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Unsafe.Primitive.Double+where++import qualified NoSlow.Backend.Vector.Unsafe.Primitive as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = Double+class Impl.Prim a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Micro/Vector/Unsafe/Storable.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Unsafe.Storable+where++import qualified NoSlow.Backend.Vector.Unsafe.Storable as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++type Spec_Vector = Impl.Vector+type Spec_Elem a = a+class Impl.Storable a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Micro/Vector/Unsafe/Storable/Double.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Unsafe.Storable.Double+where++import qualified NoSlow.Backend.Vector.Unsafe.Storable as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = Double+class Impl.Storable a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Micro/Vector/Unsafe/Unboxed.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Unsafe.Unboxed+where++import qualified NoSlow.Backend.Vector.Unsafe.Unboxed as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++type Spec_Vector = Impl.Vector+type Spec_Elem a = a+class Impl.Unbox a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Micro/Vector/Unsafe/Unboxed/Double.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Micro.Vector.Unsafe.Unboxed.Double+where++import qualified NoSlow.Backend.Vector.Unsafe.Unboxed as Impl+import qualified NoSlow.Micro.Kernels as K+import NoSlow.Backend.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = Double+class Impl.Unbox a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Mini/DPH/Prim/Seq.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Mini.DPH.Prim.Seq+where++import qualified NoSlow.Backend.DPH.Prim.Seq as Impl+import qualified NoSlow.Mini.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++type Spec_Vector = Impl.Array+type Spec_Elem = ()+class Impl.Elt a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Mini/Kernels.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE TemplateHaskell, FlexibleContexts #-}+module NoSlow.Mini.Kernels ( kernels ) where++import qualified NoSlow.Backend.Interface as I+import NoSlow.Util.Base+import NoSlow.Util.Computation ( Len(..), WithSqrtLen(..), Sorted(..),+ ParenTree(..), Edges(..) )++import Data.Bits++kernels = [d|+ -- Wyllie's list ranking based on pointer jumping. Based on+ -- http://www.cs.cmu.edu/~scandal/nesl/algorithms.html+ list_rank :: I.Vector v a => Ty (v a) -> Len -> v Int+ list_rank _ (Len n) = pointer_jump list val+ where+ list = 0 `I.cons` I.enumFromTo_Int 0 (n-2)++ val = I.zipWith (\i j -> if i == j then 0 else 1)+ list (I.enumFromTo_Int 0 (n-1))++ pointer_jump pt val+ | npt == pt = val+ | otherwise = pointer_jump npt nval+ where+ npt = I.backpermute pt pt;+ nval = I.zipWith (+) val (I.backpermute val pt)++ -- Tree rootfix based on+ -- http://www.cse.unsw.edu.au/~rl/publications/recycling.html+ rootfix_depth :: I.Vector v a => Ty (v a) -> ParenTree v Int -> v Int+ rootfix_depth _ (ParenTree ls rs)+ = rootfix (I.replicate (I.length ls) 1) ls rs+ where+ rootfix xs ls rs+ = let zs = I.replicate (I.length ls * 2) 0+ vs = I.update_ (I.update_ zs ls xs) rs (I.map negate xs)+ sums = I.prescanl' (+) 0 vs+ in+ I.backpermute sums ls++ -- Tree leaffix based on+ -- http://www.cse.unsw.edu.au/~rl/publications/recycling.html+ leaffix_size :: I.Vector v a => Ty (v a) -> ParenTree v Int -> v Int+ leaffix_size _ (ParenTree ls rs)+ = leaffix (I.replicate (I.length ls) 1) ls rs+ where+ leaffix xs ls rs+ = let zs = I.replicate (I.length ls * 2) 0+ vs = I.update_ zs ls xs+ sums = I.prescanl' (+) 0 vs+ in+ I.zipWith (-) (I.backpermute sums ls) (I.backpermute sums rs)++ -- Awerbuch-Shiloach connected components. Based on+ -- http://www.cs.cmu.edu/~scandal/nesl/algorithms.html+ awsh_cc :: I.Vector v a => Ty (v a) -> Edges v Int -> v Int+ awsh_cc _ (Edges n es1 es2)+ = concomp ds es1' es2'+ where+ ds = I.enumFromTo_Int 0 (n-1) `I.append` I.enumFromTo_Int 0 (n-1)+ es1' = es1 `I.append` es2+ es2' = es2 `I.append` es1++ starCheck ds = I.backpermute st' gs+ where+ gs = I.backpermute ds ds+ st = I.zipWith (==) ds gs+ st' = I.update st . I.filter (not . I.snd)+ $ I.zip gs st++ concomp ds es1 es2+ | I.and (starCheck ds'') = ds''+ | otherwise = concomp (I.backpermute ds'' ds'') es1 es2+ where+ ds' = I.update ds+ . I.map (\t -> case I.from3 t of (di, dj, gi) -> di `I.pair` dj)+ . I.filter (\t -> case I.from3 t of+ (di, dj, gi) -> gi == di && di > dj)+ $ I.zip3 (I.backpermute ds es1)+ (I.backpermute ds es2)+ (I.backpermute ds (I.backpermute ds es1))++ ds'' = I.update ds'+ . I.map (\t -> case I.from3 t of (di, dj, st) -> di `I.pair` dj)+ . I.filter (\t -> case I.from3 t of+ (di, dj, st) -> st && di /= dj)+ $ I.zip3 (I.backpermute ds' es1)+ (I.backpermute ds' es2)+ (I.backpermute (starCheck ds') es1)++ -- Awerbuch-Shiloach/random mate hybrid connected components. Based on+ -- http://www.cs.cmu.edu/~scandal/nesl/algorithms.html+ hyb_cc :: I.Vector v a => Ty (v a) -> Edges v Int -> v Int+ hyb_cc _ (Edges n e1 e2) = concomp (I.zip e1 e2) n+ where+ concomp es n+ | I.null es = I.enumFromTo_Int 0 (n-1)+ | otherwise = I.backpermute ins ins+ where+ p = shortcut_all+ $ I.update (I.enumFromTo_Int 0 (n-1)) es++ (es',i) = compress p es+ r = concomp es' (I.length i)+ ins = I.update_ p i+ $ I.backpermute i r++ enumerate bs = I.prescanl' (+) 0 $ I.map (\b -> if b then 1 else 0) bs++ pack_index bs = I.map I.fst+ . I.filter I.snd+ $ I.zip (I.enumFromTo_Int 0 (I.length bs - 1)) bs++ shortcut_all p | p == pp = pp+ | otherwise = shortcut_all pp+ where+ pp = I.backpermute p p++ compress p es = (new_es, pack_index roots)+ where+ (e1,e2) = I.from2 $ I.unzip es+ es' = I.map (\t -> if I.fst t > I.snd t then I.snd t `I.pair` I.fst t+ else I.fst t `I.pair` I.snd t)+ . I.filter (\t -> I.fst t /= I.snd t)+ $ I.zip (I.backpermute p e1) (I.backpermute p e2)++ roots = I.zipWith (==) p (I.enumFromTo_Int 0 (I.length p - 1))+ labels = enumerate roots+ (e1',e2') = I.from2 $ I.unzip es'+ new_es = I.zip (I.backpermute labels e1') (I.backpermute labels e2')++ -- Quickhull. Based on+ -- http://www.cs.cmu.edu/~scandal/nesl/algorithms.html+ quickhull :: I.Vector v a => Ty (v a) -> v Double -> v Double+ -> (v Double, v Double)+ quickhull _ xs ys+ = I.from2 $ I.unzip+ $ hsplit points pmin pmax `I.append` hsplit points pmax pmin+ where+ imin = I.minIndex xs+ imax = I.maxIndex xs++ points = I.zip xs ys+ pmin = I.index points imin+ pmax = I.index points imax+++ hsplit points p1 p2+ | I.length packed < 2 = p1 `I.cons` packed+ | otherwise = hsplit packed p1 pm `I.append` hsplit packed pm p2+ where+ cs = I.map (\p -> cross p p1 p2) points+ packed = I.map I.fst+ $ I.filter (\t -> I.snd t > 0)+ $ I.zip points cs++ pm = I.index points (I.maxIndex cs)+++ cross p p1 p2 = case I.from2 p of { (x,y) ->+ case I.from2 p1 of { (x1,y1) ->+ case I.from2 p2 of { (x2,y2) ->+ (x1-x)*(y2-y) - (y1-y)*(x2-x) }}}++ -- Inner loop from the spectral-norm benchmark from+ -- http://shootout.alioth.debian.org+ spectral_norm+ :: I.Vector v a => Ty (v a) -> WithSqrtLen (v Double) -> v Double+ spectral_norm _ (WithSqrtLen us)+ = n `seq` us `seq` I.map row (I.enumFromTo_Int 0 (n-1))+ where+ n = I.length us++ row i = i `seq` I.sum (I.imap (\j u -> eval_A i j * u) us)++ eval_A i j = 1 / fromIntegral r+ where+ r = u + (i+1)+ u = t `shiftR` 1+ t = n * (n+1)+ n = i+j++ -- Tridiagonal matrix solver+ tridiagonal :: I.Vector v a => Ty (v a)+ -> v Double -> v Double -> v Double -> v Double+ -> v Double+ tridiagonal _ as bs cs ds = xs+ where+ (cs',ds') = I.from2+ $ I.unzip+ $ I.prescanl' modify (I.pair 0 0)+ $ I.zip (I.zip as bs) (I.zip cs ds)++ modify p q = case I.from2 p of { (c',d') ->+ case I.from2 q of { (q1,q2) ->+ case I.from2 q1 of { (a,b) ->+ case I.from2 q2 of { (c,d) ->+ let id = 1 / (b - c'*a)+ in+ id `seq` I.pair (c*id) ((d-d'*a)*id) }}}}++ xs = I.prescanr' (\p x' -> case I.from2 p of (c,d) -> d - c*x')+ 0 (I.zip cs' ds')++ |]+
+ NoSlow/Mini/List.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Mini.List+where++import qualified NoSlow.Backend.List as Impl+import qualified NoSlow.Mini.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++type Spec_Vector = []+type Spec_Elem = ()+class Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Mini/StorableVector.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Mini.StorableVector+where++import qualified NoSlow.Backend.StorableVector as Impl+import qualified NoSlow.Mini.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = ()+class Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Mini/Uvector.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Mini.Uvector+where++import qualified NoSlow.Backend.Uvector as Impl+import qualified NoSlow.Mini.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++type Spec_Vector = Impl.UArr+type Spec_Elem = ()+class Impl.UA a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Mini/Vector/Boxed.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Mini.Vector.Boxed+where++import qualified NoSlow.Backend.Vector as Impl+import qualified NoSlow.Mini.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = ()+class Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Mini/Vector/Primitive.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Mini.Vector.Primitive+where++import qualified NoSlow.Backend.Vector.Primitive as Impl+import qualified NoSlow.Mini.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = ()+class Impl.Prim a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Mini/Vector/Storable.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Mini.Vector.Storable+where++import qualified NoSlow.Backend.Vector.Storable as Impl+import qualified NoSlow.Mini.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = ()+class Impl.Storable a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Mini/Vector/Unboxed.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Mini.Vector.Unboxed+where++import qualified NoSlow.Backend.Vector.Unboxed as Impl+import qualified NoSlow.Mini.Kernels as K+import NoSlow.Backend.TH++import Language.Haskell.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = ()+class Impl.Unbox a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Mini/Vector/Unsafe/Boxed.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Mini.Vector.Unsafe.Boxed+where++import qualified NoSlow.Backend.Vector.Unsafe as Impl+import qualified NoSlow.Mini.Kernels as K+import NoSlow.Backend.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = ()+class Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Mini/Vector/Unsafe/Primitive.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Mini.Vector.Unsafe.Primitive+where++import qualified NoSlow.Backend.Vector.Unsafe.Primitive as Impl+import qualified NoSlow.Mini.Kernels as K+import NoSlow.Backend.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = ()+class Impl.Prim a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Mini/Vector/Unsafe/Storable.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Mini.Vector.Unsafe.Storable+where++import qualified NoSlow.Backend.Vector.Unsafe.Storable as Impl+import qualified NoSlow.Mini.Kernels as K+import NoSlow.Backend.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = ()+class Impl.Storable a => Spec_Context v a++$(specialise K.kernels)+
+ NoSlow/Mini/Vector/Unsafe/Unboxed.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}+module NoSlow.Mini.Vector.Unsafe.Unboxed+where++import qualified NoSlow.Backend.Vector.Unsafe.Unboxed as Impl+import qualified NoSlow.Mini.Kernels as K+import NoSlow.Backend.TH++type Spec_Vector = Impl.Vector+type Spec_Elem = ()+class Impl.Unbox a => Spec_Context v a++$(specialise K.kernels)+
NoSlow/Util/Base.hs view
@@ -1,7 +1,6 @@ module NoSlow.Util.Base (- Ty(..), ofType, named, Unsupported(..),-- Len(..)+ Ty(..), ofType, named, Unsupported(..), Sort(..),+ noinline ) where data Ty a = Ty@@ -16,5 +15,9 @@ data Unsupported = Unsupported -newtype Len = Len { unLen :: Int }+data Sort = Generic | Specialised deriving (Eq, Ord, Show)++noinline :: a -> a+{-# NOINLINE noinline #-}+noinline x = x
NoSlow/Util/Computation.hs view
@@ -1,88 +1,228 @@ {-# LANGUAGE TypeOperators, TypeFamilies, FlexibleContexts, CPP #-} module NoSlow.Util.Computation (- DeepSeq(..), TestData(..), Computation(..),+ DeepSeq(..), TestData(..), -- Computation(..), - Nil(..), (:>)(..)+ ListLike(..), testList,++ Len(..), WithSqrtLen(..), Sorted(..), ParenTree(..), Edges(..),+ ConnectedEdges(..),+ -- Nil(..), (:>)(..),++ generateData ) where -import NoSlow.Util.Base ( Len(..) )+import Statistics.RandomVariate+import qualified Data.Array.ST as STA+import Control.Monad.ST ( ST, runST )+import Control.Monad+import Data.List ( sort ) + class DeepSeq a where deepSeq :: a -> b -> b deepSeq = seq -instance DeepSeq Len+ -- NOTE: The dummy method is necessary because 6.13 doesn't optimise newtype+ -- DFuns correctly. See http://hackage.haskell.org/trac/ghc/ticket/3772.+ deepSeqDummy :: a+ deepSeqDummy = undefined+ instance DeepSeq Int instance DeepSeq Float-instance DeepSeq Double+instance DeepSeq Double where+ deepSeq = seq+instance DeepSeq Bool +instance (DeepSeq a, DeepSeq b) => DeepSeq (a,b) where+ {-# INLINE deepSeq #-}+ deepSeq (a,b) x = deepSeq a $ deepSeq b x++instance (DeepSeq a, DeepSeq b, DeepSeq c) => DeepSeq (a,b,c) where+ {-# INLINE deepSeq #-}+ deepSeq (a,b,c) x = deepSeq a $ deepSeq b $ deepSeq c x++instance (DeepSeq a, DeepSeq b, DeepSeq c, DeepSeq d) => DeepSeq (a,b,c,d) where+ {-# INLINE deepSeq #-}+ deepSeq (a,b,c,d) x = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d x++instance (DeepSeq a, DeepSeq b, DeepSeq c, DeepSeq d, DeepSeq e)+ => DeepSeq (a,b,c,d,e) where+ {-# INLINE deepSeq #-}+ deepSeq (a,b,c,d,e) x = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d+ $ deepSeq e x+ instance DeepSeq a => DeepSeq [a] where- deepSeq xs b = foldr deepSeq b xs+ -- NOTE: We can't use foldr deepSeq b xs here because GHC 6.12 won't+ -- optimise it+ {-# INLINE deepSeq #-}+ deepSeq xs b = go xs+ where+ go [] = b+ go (x:xs) = x `deepSeq` go xs class DeepSeq a => TestData a where- testData :: Int -> a- testList :: Int -> [a]-- testList n = replicate n (testData n)+ testData :: Int -> Gen s -> ST s a -instance TestData Len where- testData n = Len n+generateData :: TestData a => Int -> a+generateData n = runST (testData n =<< create) instance TestData Int where- testData _ = 1- testList n = [1..n]+ testData _ = uniform instance TestData Float where- testData _ = 1- testList n = [1..fromIntegral n]+ testData _ = uniform instance TestData Double where- testData _ = 1- testList n = [1..fromIntegral n]+ testData _ = uniform +instance (TestData a, TestData b) => TestData (a,b) where+ testData n g = liftM2 (,) (testData n g) (testData n g)++instance (TestData a, TestData b, TestData c) => TestData (a,b,c) where+ testData n g = liftM3 (,,) (testData n g) (testData n g) (testData n g)++instance (TestData a, TestData b, TestData c, TestData d)+ => TestData (a,b,c,d) where+ testData n g = liftM4 (,,,) (testData n g) (testData n g) (testData n g)+ (testData n g)++instance (TestData a, TestData b, TestData c, TestData d, TestData e)+ => TestData (a,b,c,d,e) where+ testData n g = liftM5 (,,,,) (testData n g) (testData n g) (testData n g)+ (testData n g) (testData n g)+ instance TestData a => TestData [a] where- testData = testList+ testData n g = sequence $ replicate n $ testData n g -data x :> xs = x :> xs-data Nil = Nil -instance DeepSeq Nil where- deepSeq Nil x = x+newtype Len = Len Int -instance TestData Nil where- testData _ = Nil+instance DeepSeq Len -instance (DeepSeq x, DeepSeq xs) => DeepSeq (x :> xs) where- deepSeq (x :> xs) y = deepSeq x $ deepSeq xs y+instance TestData Len where+ testData n _ = return (Len n) -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+newtype WithSqrtLen a = WithSqrtLen a - apply :: a -> Arg a -> Res a+instance DeepSeq a => DeepSeq (WithSqrtLen a) where+ deepSeq (WithSqrtLen xs) = deepSeq xs -#define ComputationResult(ty) \-instance Computation (ty) where { \- type Arg (ty) = Nil \-; type Res (ty) = ty \-; apply x _ = x }+instance TestData a => TestData (WithSqrtLen a) where+ testData n g = WithSqrtLen `fmap` testData n' g+ where+ n' = floor $ sqrt $ fromIntegral n -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+class ListLike l a where+ fromList :: [a] -> l a -instance (TestData a, Computation b) => Computation (a -> b) where- type Arg (a -> b) = a :> Arg b- type Res (a -> b) = Res b+instance ListLike [] a where+ fromList = id - apply f (x :> xs) = apply (f x) xs+testList :: (TestData a, ListLike l a) => Int -> Gen s -> ST s (l a)+testList n g = fromList `fmap` testData n g++newtype Sorted l a = Sorted (l a)++instance DeepSeq (l a) => DeepSeq (Sorted l a) where+ deepSeq (Sorted xs) y = deepSeq xs y++instance (Ord a, TestData a, DeepSeq (l a), ListLike l a)+ => TestData (Sorted l a) where+ testData n g = do+ xs <- testData n g+ return $ Sorted $ fromList $ sort xs+++parenTree :: Int -> ([Int],[Int])+parenTree n = case go ([],[]) 0 (if even n then n else n+1) of+ (ls,rs) -> (reverse ls, reverse rs)+ where+ go (ls,rs) i j = case j-i of+ 0 -> (ls,rs)+ 2 -> (ls',rs')+ d -> let k = ((d-2) `div` 4) * 2+ in+ go (go (ls',rs') (i+1) (i+1+k)) (i+1+k) (j-1)+ where+ ls' = i:ls+ rs' = j-1:rs++data ParenTree l a = ParenTree (l a) (l a)++instance DeepSeq (l a) => DeepSeq (ParenTree l a) where+ deepSeq (ParenTree t u) x = deepSeq t (deepSeq u x)++instance (DeepSeq (l Int), ListLike l Int) => TestData (ParenTree l Int) where+ testData n _ = case parenTree n of+ (ls,rs) -> return $ ParenTree (fromList ls) (fromList rs)+++randomGraph :: Int -> Int -> Gen s -> ST s ([Int], [Int])+randomGraph n e g+ = do+ arr <- STA.newArray (0,n-1) [] :: ST s (STA.STArray s Int [Int])+ addRandomEdges n g arr e+ xs <- STA.getAssocs arr+ return $ unzip $ [(i,j) | (i,js) <- xs, j <- js ]++randomConnectedGraph :: Int -> Int -> Gen s -> ST s ([Int], [Int])+randomConnectedGraph n e g+ = do+ arr <- STA.newListArray (0,n-1) $ [[n] | n <- [1 .. n-1]] ++ [[]]+ :: ST s (STA.STArray s Int [Int])+ addRandomEdges n g arr e+ xs <- STA.getAssocs arr+ return $ unzip $ [(i,j) | (i,js) <- xs, j <- js ]+++addRandomEdges :: Int -> Gen s -> STA.STArray s Int [Int] -> Int -> ST s ()+addRandomEdges n g arr = fill+ where+ fill 0 = return ()+ fill e+ = do+ m <- random_index+ n <- random_index+ let lo = min m n+ hi = max m n+ ns <- STA.readArray arr lo+ if lo == hi || hi `elem` ns+ then fill e+ else do+ STA.writeArray arr lo (hi:ns)+ fill (e-1)++ random_index = do+ x <- uniform g+ let i = floor ((x::Double) * toEnum n)+ if i == n then return 0 else return i+++data Edges l a = Edges Int (l a) (l a)++instance DeepSeq (l a) => DeepSeq (Edges l a) where+ deepSeq (Edges n t u) x = n `seq` deepSeq t (deepSeq u x)++instance (DeepSeq (l Int), ListLike l Int) => TestData (Edges l Int) where+ testData n g = do+ (xs,ys) <- randomGraph nodes n g+ return $ Edges nodes (fromList xs) (fromList ys)+ where+ nodes = n `div` 10+++data ConnectedEdges l a = ConnectedEdges Int (l a) (l a)++instance DeepSeq (l a) => DeepSeq (ConnectedEdges l a) where+ deepSeq (ConnectedEdges n t u) x = n `seq` deepSeq t (deepSeq u x)++instance (DeepSeq (l Int), ListLike l Int)+ => TestData (ConnectedEdges l Int) where+ testData n g = do+ (xs,ys) <- randomGraph nodes n g+ return $ ConnectedEdges nodes (fromList xs) (fromList ys)+ where+ nodes = n `div` 10
+ NoSlow/Util/Opts.hs view
@@ -0,0 +1,141 @@+module NoSlow.Util.Opts ( OptM, update, exit, error, parse, parseAll,+ printError,+ noArg, reqArg, readArg, helpArg, listArg,+ selArg, matchName, matchLib, matchGroup )+where++import NoSlow.Util.Tag++import System.Console.GetOpt+import System.Exit+import System.Environment ( getProgName )+import System.IO ( stderr, hPutStrLn )++import Data.List ( foldl' )+import Data.Monoid+import Prelude hiding ( error, read )++data Result a = Ok a+ | Exit (IO ()) ExitCode+ | Error String++instance Functor Result where+ fmap f r = r >>= return . f++instance Monad Result where+ return = Ok++ Ok x >>= f = f x+ Exit p c >>= _ = Exit p c+ Error s >>= _ = Error s++newtype OptM a = OptM (a -> Result a)++instance Monoid (OptM a) where+ mempty = OptM Ok+ mappend (OptM f) o = OptM (apply o . f)++result :: Result a -> OptM a+result = OptM . const++update :: (a -> a) -> OptM a+update f = OptM $ Ok . f++exit :: IO () -> ExitCode -> OptM a+exit p = result . Exit p++error :: String -> OptM a+error = result . Error++errorMsg :: String -> OptM a -> OptM a+errorMsg msg (OptM f) = OptM $ \x -> case f x of+ Error _ -> Error msg+ r -> r++check :: Bool -> OptM a -> OptM a+check True o = o+check False _ = error "invalid argument"++read :: Read a => (a -> OptM b) -> String -> OptM b+read f s = case reads s of+ [(x,"")] -> f x+ _ -> error "invalid argument"++require :: (a -> Bool) -> (a -> OptM b) -> a -> OptM b+require f g x = check (f x) (g x)++apply :: OptM a -> Result a -> Result a+apply (OptM f) r = r >>= f++chain :: Result a -> (a -> OptM b) -> OptM b+chain r o = OptM $ \x -> do { a <- r; run (o a) x }+ +run :: OptM a -> a -> Result a+run (OptM f) x = f x++parse :: a -> [OptDescr (OptM a)] -> [String] -> IO (a, [String])+parse a options args+ = case getOpt Permute options args of+ (os, args', []) ->+ case run (mconcat os) a of+ Ok r -> return (r, args')+ Exit p c -> do { p; exitWith c }+ Error s -> printError s+ (_, _, (s : _)) -> printError s++parseAll :: a -> [OptDescr (OptM a)] -> [String] -> IO a+parseAll a options args+ = do+ (r, args') <- parse a options args+ case args' of+ [] -> return r+ s : _ -> printError $ "extra argument `" ++ s ++ "'" ++printError :: String -> IO a+printError msg+ = do+ prog <- getProgName+ hPutStrLn stderr $ "Error: " ++ msg+ hPutStrLn stderr $ "Run \"" ++ prog+ ++ " --help\" for usage information"+ exitWith (ExitFailure 1)++noArg :: (a -> a) -> ArgDescr (OptM a)+noArg = NoArg . update++reqArg :: (String -> a -> a) -> String -> ArgDescr (OptM a)+reqArg f = ReqArg (update . f)++readArg :: Read a => String -> (a -> Bool) -> (a -> b -> b)+ -> String -> ArgDescr (OptM b)+readArg s f g = ReqArg (errorMsg msg . (read $ require f $ update . g))+ where+ msg = "invalid " ++ s++helpArg :: IO () -> ArgDescr (OptM a)+helpArg p = NoArg (exit p ExitSuccess)++listArg :: (String -> Result a) -> ([a] -> b -> b)+ -> String -> ArgDescr (OptM b)+listArg f g = ReqArg $ \s -> chain (mapM f (split ',' s)) (update . g)++selArg :: (String -> Result (Tag -> Bool))+ -> ((Tag -> Bool) -> a -> a) -> String -> ArgDescr (OptM a)+selArg f g = listArg f (g . foldr or (const False))+ where+ or f g t = f t || g t++matchName :: String -> Result (Tag -> Bool)+matchName s = Ok $ \t -> tagName t == s++matchLib :: String -> Result (Tag -> Bool)+matchLib "" = Ok $ const False+matchLib s = case split '/' s of+ [lib] -> Ok $ \t -> tagLibrary t == lib+ [lib,sub] -> Ok $ \t -> tagLibrary t == lib+ && tagSubsystem t == sub+ _ -> Error $ "Invalid library " ++ s++matchGroup :: String -> Result (Tag -> Bool)+matchGroup grp = Ok $ \t -> tagGroup t == grp+
+ NoSlow/Util/Tag.hs view
@@ -0,0 +1,43 @@+module NoSlow.Util.Tag ( Tag(..), Sort(..), split )+where++import NoSlow.Util.Base ( Sort(..) )++data Tag = Tag {+ tagLibrary :: String+ , tagSubsystem :: String+ , tagGroup :: String+ , tagName :: String+ }+ deriving( Eq, Ord )++instance Show Tag where+ showsPrec _ t = showString (tagLibrary t) . showChar '/'+ . (if null (tagSubsystem t)+ then id+ else showString (tagSubsystem t) . showChar '/')+ . showString (tagGroup t)+ . (if null (tagName t)+ then id+ else showChar '/' . showString (tagName t))++instance Read Tag where+ readsPrec _ s+ = case split '/' s of+ [lib, sub, grp, name] -> [(mk_tag lib sub grp name, "")]+ [lib, grp, name] -> [(mk_tag lib "" grp name, "")]+ _ -> []+ where++ mk_tag lib sub grp name+ = Tag { tagLibrary = lib+ , tagSubsystem = sub+ , tagGroup = grp+ , tagName = name+ }++split :: Char -> String -> [String]+split c xs = case span (/= c) xs of+ (ys,[]) -> [ys]+ (ys, _ : zs) -> ys : split c zs+
− Table.hs
@@ -1,254 +0,0 @@-{-# 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-