diff --git a/Data/Array/Vector.hs b/Data/Array/Vector.hs --- a/Data/Array/Vector.hs +++ b/Data/Array/Vector.hs @@ -44,6 +44,7 @@ snocU, -- uncons appendU, + concatU, headU, lastU, tailU, @@ -62,6 +63,8 @@ foldlU, foldl1U, + foldrU, + foldr1U, foldl1MaybeU, -- ** Logical operations diff --git a/Data/Array/Vector/Stream.hs b/Data/Array/Vector/Stream.hs --- a/Data/Array/Vector/Stream.hs +++ b/Data/Array/Vector/Stream.hs @@ -377,6 +377,34 @@ Skip s' -> s' `seq` fold1 z s' Yield x s' -> s' `seq` fold1 (f z x) s' +-- | 'foldrS', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a stream, +-- reduces the stream using the binary operator, from right to left. +foldrS :: (a -> b -> b) -> b -> Stream a -> b +foldrS f z (Stream next s0 _len) = loop_foldr s0 + where + loop_foldr !s = case next s of + Done -> z + Skip s' -> loop_foldr s' + Yield x s' -> f x (loop_foldr s') +{-# INLINE [0] foldrS #-} + +-- | foldr1S is a variant of 'foldrS' that has no starting value +-- argument, and thus must be applied to non-empty streams. +foldr1S :: (a -> a -> a) -> Stream a -> a +foldr1S f (Stream next s0 _len) = loop0_foldr1 s0 + where + loop0_foldr1 !s = case next s of + Done -> error "foldr1S: empty stream" + Skip s' -> loop0_foldr1 s' + Yield x s' -> loop_foldr1 x s' + + loop_foldr1 x !s = case next s of + Done -> x + Skip s' -> loop_foldr1 x s' + Yield x' s' -> f x (loop_foldr1 x' s') +{-# INLINE [0] foldr1S #-} + -- | Scanning -- scanS :: (b -> a -> b) -> b -> Stream a -> Stream b diff --git a/Data/Array/Vector/Strict/Basics.hs b/Data/Array/Vector/Strict/Basics.hs --- a/Data/Array/Vector/Strict/Basics.hs +++ b/Data/Array/Vector/Strict/Basics.hs @@ -165,6 +165,11 @@ {-# INLINE_U appendU #-} a1 `appendU` a2 = unstreamU (streamU a1 +++ streamU a2) +-- |/O(n)/. Concatenate a list of arrays. +concatU :: UA e => [UArr e] -> UArr e +concatU as = unstreamU (foldr (+++) emptyS (map streamU as)) +{-# INLINE concatU #-} + -- |/O(n)/. 'initU' yields the input array without its last element. initU :: UA e => UArr e -> UArr e -- not unboxing initU = unstreamU . initS . streamU @@ -269,6 +274,19 @@ foldl1U :: UA a => (a -> a -> a) -> UArr a -> a foldl1U f = foldl1S f . streamU {-# INLINE foldl1U #-} + +-- | /O(n)/ 'foldrU', applied to a binary operator, a starting value +-- (typically the right-identity of the operator), and a 'UArr a', +-- reduces the 'UArr a' using the binary operator, from right to left. +foldrU :: UA a => (a -> b -> b) -> b -> UArr a -> b +foldrU f z = foldrS f z . streamU +{-# INLINE foldrU #-} + +-- | /O(n)/ A variant of 'foldr' that has no starting value argument, +-- and thus must be applied to a non-empty 'UArr a'. +foldr1U :: UA a => (a -> a -> a) -> UArr a -> a +foldr1U f = foldr1S f . streamU +{-# INLINE foldr1U #-} -- |/O(n)/. 'foldl1MaybeU' behaves like 'foldl1U' but returns 'NothingS' if the -- input array is empty. diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,3 +1,17 @@ +Bounds checking bugs: + + The ghc-compiled program that produces this error reads: + + import Data.Array.Vector + + main = print s + where + s :: UArr Double + s = replicateU (-1) 2 + + + +------------------------------------------------------------------------ Direction: * Fill out API diff --git a/examples/Makefile b/examples/Makefile deleted file mode 100644 --- a/examples/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -TESTDIR=. -include $(TESTDIR)/mk/test.mk - -SUBDIRS = concomp dotp primes smvm qsort - -.PHONY: all bench clean - -all: bench - for i in $(SUBDIRS) ; do \ - $(MAKE) -C $$i ; \ - done - -bench: - $(MAKE) -C lib - -clean: - for i in $(SUBDIRS) ; do \ - $(MAKE) -C $$i clean ; \ - done - $(MAKE) -C lib clean - - diff --git a/examples/README b/examples/README deleted file mode 100644 --- a/examples/README +++ /dev/null @@ -1,59 +0,0 @@ -NDP benchmarks -============== - -This directory contains several NDP benchmarks: - -concomp - connected components in undirected graphs -dotp - dot product of two vectors -primes - sieve of Eratosthenes -smvm - sparse matrix/vector multiplication - -Options -------- - -The following options are common to all benchmarks: - - --runs=N Repeat each benchmark N times - -r N - - --threads=N Use N threads - -t N - - --seq=N Simulate N threads - -s N - - --algo=ALGORITHM Use the specified algorithm (if the benchmark - -a ALGORITHM implements multiple algorithms) - - --verbose=N Set the verbosity level - -v N - - --help Show a help screen - -Running benchmarks ------------------- - -For parallel benchmarks, you usually want to use - - benchmark --threads= --runs= +RTS -N - -Here, N is the number of threads to use and R the number of times the -benchmark should be repeated (you probably want something between 3 and 10). - -The output will look as follows: - - ....: wall_best/cpu_best wall_avg/cpu_avg wall_worst/cpu_worst - -Here, wall_{best|avg|worst} is the best, average and worst wall-clock time, -respectively; cpu_{best|avg|worst} is the CPU time. Note that for parallel -benchmarks on a multiprocessor, the wall-clock time will typically decrease -with more threads whereas the CPU time will slightly increase. - -For sequential benchmarks, the number of threads does not have to be -specified, i.e., --threads and +RTS -N can be omitted. - -At higher verbosity levels, more information (in particular, the timings of -the individual runs) will be displayed. - - - diff --git a/examples/barhesHut/BarnesHut.hs b/examples/barhesHut/BarnesHut.hs deleted file mode 100644 --- a/examples/barhesHut/BarnesHut.hs +++ /dev/null @@ -1,101 +0,0 @@ -module Main where -import BarnesHutSeq -import BarnesHutPar -import qualified BarnesHutVect as V -import BarnesHutGen - -import Control.Exception (evaluate) -import System.Console.GetOpt - -import Data.Array.Parallel.Unlifted -import Data.Array.Parallel.Unlifted.Parallel - -import Bench.Benchmark -import Bench.Options -import Data.Array.Parallel.Prelude (toUArrPA, fromUArrPA_3') - -import Debug.Trace - - - -algs = [("seqSimple", bhStepSeq), ("parSimple", bhStepPar), ("vect", bhStepVect)] - -bhStepSeq (dx, dy, particles) = trace (showBHTree bhtree) accs - where - accs = calcAccel bhtree (flattenSU particles) - bhtree = splitPointsL (singletonU ((0.0 :*: 0.0) :*: (dx :*: dy))) particles - -bhStepPar (dx, dy, particles) = trace (showBHTree bhTree) accs - where - accs = calcAccel bhTree (flattenSU particles) - bhTree = splitPointsLPar (singletonU ((0.0 :*: 0.0) :*: (dx :*: dy))) - particles - -bhStepVect (dx, dy, particles) = trace (show accs) accs - where - accs = zipU (toUArrPA xs) (toUArrPA ys) - (xs, ys) = V.oneStep 0.0 0.0 dx dy particles' - particles' = (fromUArrPA_3' $ flattenSU particles) - - - -mapData:: IO (Bench.Benchmark.Point (UArr Double)) -mapData = do - evaluate testData - return $ ("N = " ) `mkPoint` testData - where - testData:: UArr Double - testData = toU $ map fromIntegral [0..10000000] - - - --- simpleTest:: -simpleTest:: [Int] -> Double -> Double -> IO (Bench.Benchmark.Point (Double, Double, SUArr MassPoint)) -simpleTest _ _ _= - do - evaluate testData - return $ ("N = " ) `mkPoint` testData - where - testData = (1.0, 1.0, singletonSU testParticles) - -- particles in the bounding box 0.0 0.0 1.0 1.0 - testParticles:: UArr MassPoint - testParticles = toU [ - 0.3 :*: 0.2 :*: 5.0, -{- --- 0.2 :*: 0.1 :*: 5.0, --- 0.1 :*: 0.2 :*: 5.0, --- 0.8 :*: 0.8 :*: 5.0, - 0.7 :*: 0.9 :*: 5.0, - 0.8 :*: 0.9 :*: 5.0, - 0.6 :*: 0.6 :*: 5.0, - 0.7 :*: 0.7 :*: 5.0, - 0.8 :*: 0.7 :*: 5.0, -} - 0.9 :*: 0.9 :*: 5.0] - - -randomDistTest n dx dy = - do - testParticles <- randomMassPointsIO dx dy - let testData = (singletonU testBox, singletonSU $ toU $ take n testParticles) - evaluate testData - return $ ("N = " ) `mkPoint` testData - - where - testBox = (0.0 :*: 0.0) :*: (dx :*: dy) - - -main = ndpMain "BarnesHut" - "[OPTION] ... SIZES ..." - run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") - "use the specified algorithm"] - "seq" - -run opts alg sizes = - case lookup alg algs of - Nothing -> failWith ["Unknown algorithm"] - Just f -> case map read sizes of - [] -> failWith ["No sizes specified"] - szs -> do - benchmark opts f [simpleTest szs 0 0] show - return () - diff --git a/examples/barhesHut/BarnesHutGen.hs b/examples/barhesHut/BarnesHutGen.hs deleted file mode 100644 --- a/examples/barhesHut/BarnesHutGen.hs +++ /dev/null @@ -1,266 +0,0 @@ -module BarnesHutGen where - -import Monad (liftM) - -import List (nubBy) -import IO -import System (ExitCode(..), getArgs, exitWith) -import Random (Random, RandomGen, getStdGen, randoms, randomRs) -import Data.Array.Parallel.Unlifted - -type Vector = (Double :*: Double) - -type Point = Vector -type Accel = Vector -type Velocity = Vector -type MassPoint = Point :*: Double -type Particle = MassPoint :*: Velocity - -type BoundingBox = Point :*: Point - -type BHTree = [BHTreeLevel] -type BHTreeLevel = (UArr MassPoint, UArr Int) -- centroids - -epsilon = 0.05 -eClose = 0.5 - --- particle generation --- ------------------- - -randomTo, randomFrom :: Integer -randomTo = 2^30 -randomFrom = - randomTo - -randomRIOs :: Random a => (a, a) -> IO [a] -randomRIOs range = liftM (randomRs range) getStdGen - -randomIOs :: Random a => IO [a] -randomIOs = liftM randoms getStdGen - --- generate a stream of random numbers in [0, 1) --- -randomDoubleIO :: IO [Double] -randomDoubleIO = randomIOs - --- generate an infinite list of random mass points located with a homogeneous --- distribution around the origin within the given bounds --- -randomMassPointsIO :: Double -> Double -> IO [MassPoint] -randomMassPointsIO dx dy = do - rs <- randomRIOs (randomFrom, randomTo) - return (massPnts rs) - where - to = fromIntegral randomTo - from = fromIntegral randomFrom - xmin = - (dx / 2.0) - ymin = - (dy / 2.0) - xfrac = (to - from) / dx - yfrac = (to - from) / dy - - massPnts :: [Integer] -> [MassPoint] - massPnts (xb:yb:mb:rs) = - ((x :*: y) :*: m) : massPnts rs - where - m = (fromInteger . abs) mb + epsilon - x = xmin + (fromInteger xb) / xfrac - y = ymin + (fromInteger yb) / yfrac - --- The mass of the generated particle cloud is standardized to about --- 5.0e7 g/m^2. The mass of individual particles may deviate by a factor of --- ten from the average. --- -smoothMass :: Double -> Double -> [MassPoint] -> [MassPoint] -smoothMass dx dy mps = let - avmass = 5.0e7 - area = dx * dy - middle = avmass * area / fromIntegral (length mps) - range = fromIntegral (randomTo - randomFrom) - factor = (middle * 10 - middle / 10) / range - - adjust (xy :*: m) = - xy :*: (middle + factor * m) - in - map adjust mps - --- Given the number of particles to generate and the horizontal and vertical --- extensions of the area where the generated particles should occur, generate --- a particle set according to a function specific strategy. --- -asymTwinParticles, - sphereParticles, - plummerParticles, - homParticles :: Int -> Double -> Double -> IO ([Particle]) - -asymTwinParticles n dx dy = error "asymTwinPrticles not implemented yet\n" - -sphereParticles n dx dy = - do - let rad = dx `min` dy - mps <- randomMassPointsIO dx dy - return (( map (\mp -> mp :*: (0.0 :*: 0.0)) - . smoothMass dx dy - . head - . filter ((== n) . length) - . map fst - . iterate refine - ) ([], filter (inside rad) mps) - ) - where - -- - -- move suitable mass points from the second list to the first (i.e., those - -- not conflicting with points that are already in the first list) - -- - refine :: ([MassPoint], [MassPoint]) -> ([MassPoint], [MassPoint]) - refine (ds, rs) = let - (ns, rs') = splitAt (n - length ds) rs - in - (nubMassPoints (ds ++ ns), rs') - - -- check whether inside the given radius - -- - inside :: Double -> MassPoint -> Bool - inside rad ((dx :*: dy) :*: _) = dx * dx + dy * dy <= rad * rad - -plummerParticles n _ _ = - do - rs <- randomDoubleIO - return (( normalize - . head - . filter ((== n) . length) - . map fst - . iterate refine - ) ([], particles rs) - ) - where - particles (w:preY:rs') = let - s_i = rsc * r_i - rsc = (3 * pi) / 16 - r_i = sqrt' ((0.999 * w)`power`(-2/3) - 1) - -- - u_i = vsc * v_i - vsc = 1 / sqrt rsc - v_i = (x * sqrt 2) / (1 + r_i^2)**(1/4) - -- - (pos :*: rs''' ) = rndVec s_i rs'' - (vel :*: rs'''') = rndVec u_i rs''' - in - ((pos :*: m) :*: vel) : particles rs'''' - where - y = preY / 101 - -- !!!should be 10, but then - -- !!!findX gets problems - (x, rs'') = findX y rs' - -- - m = 1 / fromIntegral n - -- - x`power`y | x == 0.0 = 0.0 - | otherwise = x**y - sqrt' x | x < 0 = 0 - | otherwise = sqrt x - - findX :: Double -> [Double] -> (Double, [Double]) - findX y (x:rs) | y <= x^2 * (1 - x^2)**(7/2) = (x, rs) - | otherwise = findX y rs - - rndVec len (x:y:rs) = let r = len / sqrt (x^2 + y^2) - in - ((r * x :*: r * y) :*: rs) - - -- move suitable mass points from the second list to the first (i.e., those - -- not conflicting with points that are already in the first list) - -- - refine :: ([Particle], [Particle]) -> ([Particle], [Particle]) - refine (ds, rs) = let - (ns, rs') = splitAt (n - length ds) rs - in - (nubParticles (ds ++ ns), rs') - - -- translate positions and velocities such that they are at the origin - -- - normalize :: [Particle] -> [Particle] - normalize ps = - let (dx :*: dy) :*: _ = centroid [mp | mp :*: _ <- ps] - ((dvx:*: dvy) :*: _) = totalMomentum ps - in - (map (translateVel (-dvx :*: -dvy)) . map (translate (-dx :*: -dy))) ps - - -homParticles n dx dy = - do - mps <- randomMassPointsIO dx dy - return (( map (\mp -> mp :*: (0.0 :*: 0.0)) - . smoothMass dx dy - . head - . filter ((== n) . length) - . map fst - . iterate refine - ) ([], mps) - ) - where - -- - -- move suitable mass points from the second list to the first (i.e., those - -- not conflicting with points that are already in the first list) - -- - refine :: ([MassPoint], [MassPoint]) -> ([MassPoint], [MassPoint]) - refine (ds, rs) = let - (ns, rs') = splitAt (n - length ds) rs - in - (nubMassPoints (ds ++ ns), rs') - - --- Drop all mass points that are too close to another. --- -nubMassPoints :: [MassPoint] -> [MassPoint] -nubMassPoints = nubBy (\(p1 :*: _) (p2 :*: _) -> epsilonEqual p1 p2) - --- Same for particles. --- -nubParticles :: [Particle] -> [Particle] -nubParticles = nubBy (\((p1 :*: _) :*: _) -> - \((p2 :*: _) :*: _) -> epsilonEqual p1 p2) - - --- Test whether the Manhattan distance between two points is smaller than --- `epsilon'. --- -epsilonEqual :: Point -> Point -> Bool -epsilonEqual (x1 :*: y1) (x2 :*: y2) = abs (x1 - x2) + abs (y1 - y2) < epsilon - - --- Calculates the centroid of a list of mass points. --- -centroid :: [MassPoint] -> MassPoint -centroid mps = let - m = sum [m | _ :*: m <- mps] - (wxs, wys) = unzip [(m * x, m * y) | (x :*: y) :*: m <- mps] - in - ((sum wxs / m) :*: (sum wys / m)) :*: m --- Calculates the total momentum. --- -totalMomentum :: [Particle] -> (Point :*: Double) -totalMomentum ps = - let - m = sum [m | ((_ :*: m) :*: _) <- ps] - (wxs, wys) = unzip [(m * x, m * y) | (_ :*: m) :*: (x:*: y) <- ps] - in - ((sum wxs / m :*: sum wys / m) :*: m) - --- translate a particle --- -translate :: Point -> Particle -> Particle -translate (dx :*: dy) (((x :*: y) :*: m) :*: vxy) = - ((x + dx :*: y + dy) :*: m) :*: vxy - --- translate the velocity of particle --- -translateVel :: Point -> Particle -> Particle -translateVel (dvx :*: dvy) (mp :*: (vx :*: vy)) = - mp :*: (vx + dvx :*: vy + dvy) - - - -showBHTree:: BHTree -> String -showBHTree treeLevels = "Tree:" ++ concat (map showBHTreeLevel treeLevels) - -showBHTreeLevel (massPnts, cents) = "\t" ++ show massPnts ++ "\n\t" ++ - show cents ++ "\n" ++ "\t\t|\n\t\t|\n" diff --git a/examples/barhesHut/BarnesHutSeq.hs b/examples/barhesHut/BarnesHutSeq.hs deleted file mode 100644 --- a/examples/barhesHut/BarnesHutSeq.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# GHC_OPTIONS -fglasgow-exts #-} -module BarnesHutSeq - -where -import Data.Array.Parallel.Unlifted -import BarnesHutGen - - - - - --- Phase 1: building the tree --- -{- --- Split massPoints according to their locations in the quadrants --- -splitPoints:: BoundingBox -> UArr MassPoint -> SUArr MassPoint -splitPoints (ll@(llx :*: lly) :*: ru@(rux :*: ruy)) particles - | noOfPoints == 0 = singletonSU particles - | otherwise = singletonSU lls +:+^ singletonSU lus +:+^ singletonSU rus +:+^ singletonSU rls - where - noOfPoints = lengthU particles - lls = filterU (inBox (ll :*: mid)) particles - lus = filterU (inBox ((llx :*: midy) :*: (midx :*: ruy ))) particles - rus = filterU (inBox (mid :*: ru )) particles - rls = filterU (inBox ((midx :*: lly) :*: (rux :*: midy))) particles - - mid@(midx :*: midy) = ((llx + rux)/2.0) :*: ((lly + ruy)/2.0) - - --} - -splitPointsL:: UArr BoundingBox -> SUArr MassPoint -> BHTree -splitPointsL bboxes particless - | lengthSU multiparticles == 0 = [(centroids, toU [])] - | otherwise = (centroids, lengthsSU multiparticles) : - (splitPointsL newBoxes multiparticles) - where - -- calculate centroid of each segment - centroids = - calcCentroids $ segmentArrU nonEmptySegd $ flattenSU particless - - -- remove empty segments - multiPointFlags = mapU ((>1)) $ lengthsSU particless - multiparticles = (splitPointsL' llbb lubb rubb rlbb) $ - packCU multiPointFlags particless - bboxes' = packU bboxes multiPointFlags - - nonEmptySegd = filterU ((>0)) $ lengthsSU particless - - -- split each box in four sub-boxes - newBoxes = merge4 llbb lubb rubb rlbb - - llbb = mapU makells bboxes' - lubb = mapU makelus bboxes' - rubb = mapU makerus bboxes' - rlbb = mapU makerls bboxes' - - makells (ll@(llx :*: lly) :*: ru@(rux :*: ruy)) = - ll :*: (((llx + rux)/2.0) :*: (((lly + ruy)/2.0))) - makelus (ll@(llx :*: lly) :*: ru@(rux :*: ruy)) = - (llx :*: ((lly + ruy)/2.0)) :*: (((llx + rux)/2.0) :*: ruy ) - makerus (ll@(llx :*: lly) :*: ru@(rux :*: ruy)) = - (((llx + rux)/2.0) :*: ((lly + ruy)/2.0)) :*: ru - makerls (ll@(llx :*: lly) :*: ru@(rux :*: ruy)) = - ((((llx + rux)/2.0) :*: lly) :*: (rux :*: ((lly + ruy)/2.0))) - -splitPointsL':: UArr BoundingBox -> - UArr BoundingBox -> - UArr BoundingBox -> - UArr BoundingBox -> - SUArr MassPoint -> - SUArr MassPoint -splitPointsL' llbb lubb rubb rlbb particless - | particlessLen == 0 = particless - | otherwise = orderedPoints - where - - -- each segment split into four subsegments with particles located in - -- the four quadrants - orderedPoints = - segmentArrU newLengths $ - flattenSU $ llsPs ^+:+^ lusPs ^+:+^ rusPs ^+:+^ rlsPs - particlessLen = lengthSU particless - pssLens = lengthsSU particless - lls = replicateSU pssLens llbb - lus = replicateSU pssLens lubb - rus = replicateSU pssLens rubb - rls = replicateSU pssLens rlbb - - - llsPs = mapSU sndS $ filterSU (uncurryS inBox) - (zipSU (replicateSU pssLens llbb) particless) - lusPs = mapSU sndS $ filterSU (uncurryS inBox) - (zipSU (replicateSU pssLens lubb) particless) - rusPs = mapSU sndS $ filterSU (uncurryS inBox) - (zipSU (replicateSU pssLens rubb) particless) - rlsPs = mapSU sndS $ filterSU (uncurryS inBox) - (zipSU (replicateSU pssLens rlbb) particless) - - newLengths = - merge4 (lengthsSU llsPs) (lengthsSU lusPs) - (lengthsSU rusPs) (lengthsSU rlsPs) - - --- Calculate centroid of each subarray --- -calcCentroids:: SUArr MassPoint -> UArr MassPoint -calcCentroids orderedPoints = centroids - where - ms = foldSU (+) 0.0 $ sndSU orderedPoints - centroids = zipWithU div' ms $ - foldSU pairP (0.0 :*: 0.0) $ - zipWithSU multCoor orderedPoints - (replicateSU (lengthsSU orderedPoints) ms) - div' m (x :*: y) = ((x/m :*: y/m) :*: m) - multCoor ((x :*: y) :*: _) m = (m * x :*: m * y) - - pairP (x1 :*: y1) (x2 :*: y2) = ((x1+x2) :*: (y1 + y2)) - - - --- phase 2: --- calculating the velocities - -calcAccel:: BHTree -> UArr MassPoint -> UArr (Double :*: Double) -calcAccel [] particles - | lengthU particles == 0 = emptyU - | otherwise = error $ "calcVelocity: reached empty tree" ++ (show particles) -calcAccel ((centroids, segd) :trees) particles = closeAccel - where - - closeAccel = splitApplyU particlesClose - ((calcAccel trees) . sndU ) - calcFarAccel - (zipU - (flattenSU $ replicateCU (lengthU particles) centroids) - (flattenSU $ replicateSU segd particles)) - particlesClose (((x1 :*: y1):*: _) :*: ((x2 :*: y2) :*: _)) = - (x1-x2)^2 + (y1-y2)^2 < eClose - -calcFarAccel:: UArr (MassPoint :*: MassPoint) -> UArr Accel -calcFarAccel = mapU accel - --- --- -accel:: MassPoint :*: MassPoint -> Accel -accel (((x1:*: y1) :*: m) :*: - ((x2:*: y2) :*: _)) | r < epsilon = (0.0 :*: 0.0) - | otherwise = (aabs * dx / r :*: aabs * dy / r) - where - rsqr = (dx * dx) + (dy * dy) - r = sqrt rsqr - dx = x1 - x2 - dy = y1 - y2 - aabs = m / rsqr - - - - - --- assumes all arr have the same length --- result [a11, a21, a31, a41, a12, a22....] -merge4:: UA a => - UArr a ->UArr a ->UArr a ->UArr a ->UArr a -merge4 a1 a2 a3 a4 = - combineU flags3 (combineU flags2 (combineU flags1 a1 a2) a3) a4 - where - flags1 = mapU even $ enumFromToU 0 (2 * len-1) - flags2 = mapU (\x -> mod x 3 /= 2) $ enumFromToU 0 (3 * len-1) - flags3 = mapU (\x -> mod x 4 /= 3) $ enumFromToU 0 (4 * len-1) - len = lengthU a1 - --- checks if particle is in box (excluding left and lower border) -inBox:: BoundingBox -> MassPoint -> Bool -inBox ((ll@(llx :*: lly) :*: ru@(rux :*: ruy))) ((px :*: py) :*: _) = - (px > llx) && (px <= rux) && (py > lly) && (py <= ruy) - - -splitApplyU:: (UA e, UA e') => (e -> Bool) -> (UArr e -> UArr e') -> (UArr e -> UArr e') -> UArr e -> UArr e' -splitApplyU p f1 f2 xsArr = combineU (mapU p xsArr) res1 res2 - where - res1 = f1 $ filterU p xsArr - res2 = f2 $ filterU (not . p) xsArr - -splitApplySU:: (UA e, UA e') => UArr Bool -> (SUArr e -> SUArr e') -> (SUArr e -> SUArr e') -> SUArr e -> SUArr e' -{-# INLINE splitApplySU #-} -splitApplySU flags f1 f2 xssArr = combineCU flags res1 res2 - where - res1 = f1 $ packCU flags xssArr - res2 = f2 $ packCU (mapU not flags) xssArr - - - - - diff --git a/examples/concomp/AwShU.hs b/examples/concomp/AwShU.hs deleted file mode 100644 --- a/examples/concomp/AwShU.hs +++ /dev/null @@ -1,45 +0,0 @@ -module AwShU ( aw_connected_components ) -where - -import Data.Array.Parallel.Unlifted - -starCheck :: UArr Int -> UArr Bool -starCheck ds = - let gs = bpermuteU ds ds - st = zipWithU (==) ds gs - st' = updateU st . filterU (not . sndS) - $ zipU gs st - in - bpermuteU st' gs - -conComp :: UArr Int -> UArr (Int :*: Int) -> Int :*: UArr Int -conComp ds es = - let es1 :*: es2 = unzipU es - ds' = updateU ds - . mapU (\(di :*: dj :*: gi) -> (di :*: dj)) - . filterU (\(di :*: dj :*: gi) -> gi == di && di > dj) - $ zip3U (bpermuteU ds es1) - (bpermuteU ds es2) - (bpermuteU ds (bpermuteU ds es1)) - ds'' = updateU ds' - . mapU (\(di :*: dj :*: st) -> (di :*: dj)) - . filterU (\(di :*: dj :*: st) -> st && di /= dj) - $ zip3U (bpermuteU ds' es1) - (bpermuteU ds' es2) - (bpermuteU (starCheck ds') es1) - in - if andU (starCheck ds'') - then 1 :*: ds'' - else rec $ conComp (bpermuteU ds'' ds'') es - where - rec (n :*: arr) = n+1 :*: arr - -aw_connected_components :: UArr (Int :*: Int) -> Int -> Int :*: UArr Int -{-# NOINLINE aw_connected_components #-} -aw_connected_components es n = - let ds = enumFromToU 0 (n-1) +:+ enumFromToU 0 (n-1) - es' = es +:+ mapU (\(j :*: i) -> i :*: j) es - r :*: cs = conComp ds es' - in - r :*: cs - diff --git a/examples/concomp/AwShUP.hs b/examples/concomp/AwShUP.hs deleted file mode 100644 --- a/examples/concomp/AwShUP.hs +++ /dev/null @@ -1,46 +0,0 @@ -module AwShUP ( aw_connected_components ) -where - -import Data.Array.Parallel.Unlifted -import Data.Array.Parallel.Unlifted.Parallel - -starCheck :: UArr Int -> UArr Bool -starCheck ds = - let gs = bpermuteUP ds ds - st = zipWithUP (==) ds gs - st' = updateUP st . filterUP (not . sndS) - $ zipU gs st - in - bpermuteUP st' gs - -conComp :: UArr Int -> UArr (Int :*: Int) -> Int :*: UArr Int -conComp ds es = - let es1 :*: es2 = unzipU es - ds' = updateUP ds - . mapUP (\(di :*: dj :*: gi) -> (di :*: dj)) - . filterUP (\(di :*: dj :*: gi) -> gi == di && di > dj) - $ zip3U (bpermuteUP ds es1) - (bpermuteUP ds es2) - (bpermuteUP ds (bpermuteUP ds es1)) - ds'' = updateUP ds' - . mapUP (\(di :*: dj :*: st) -> (di :*: dj)) - . filterUP (\(di :*: dj :*: st) -> st && di /= dj) - $ zip3U (bpermuteUP ds' es1) - (bpermuteUP ds' es2) - (bpermuteUP (starCheck ds') es1) - in - if andUP (starCheck ds'') - then 1 :*: ds'' - else rec $ conComp (bpermuteUP ds'' ds'') es - where - rec (n :*: arr) = n+1 :*: arr - -aw_connected_components :: UArr (Int :*: Int) -> Int -> Int :*: UArr Int -{-# NOINLINE aw_connected_components #-} -aw_connected_components es n = - let ds = enumFromToU 0 (n-1) +:+ enumFromToU 0 (n-1) - es' = es +:+ mapU (\(j :*: i) -> i :*: j) es - r :*: cs = conComp ds es' - in - r :*: cs - diff --git a/examples/concomp/Graph.hs b/examples/concomp/Graph.hs deleted file mode 100644 --- a/examples/concomp/Graph.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Graph -where - -import Data.Array.Parallel.Unlifted - -import System.IO -import Foreign - -data Graph = Graph { nodeCount :: Int - , edgeCount :: Int - , edges :: UArr (Int :*: Int) - } - deriving(Read,Show) - -hPutGraph :: Handle -> Graph -> IO () -hPutGraph h (Graph { nodeCount = n, edgeCount = e, edges = edges }) - = alloca $ \iptr -> - do - poke iptr n - hPutBuf h iptr (sizeOf n) - poke iptr e - hPutBuf h iptr (sizeOf e) - hPutU h edges - -hGetGraph :: Handle -> IO Graph -hGetGraph h - = alloca $ \iptr -> - do - hGetBuf h iptr (sizeOf (undefined :: Int)) - n <- peek iptr - hGetBuf h iptr (sizeOf (undefined :: Int)) - e <- peek iptr - edges <- hGetU h - return $ Graph { nodeCount = n, edgeCount = e, edges = edges } - -storeGraph :: FilePath -> Graph -> IO () -storeGraph file g = withBinaryFile file WriteMode (`hPutGraph` g) - -loadGraph :: FilePath -> IO Graph -loadGraph file = withBinaryFile file ReadMode hGetGraph - diff --git a/examples/concomp/HybU.hs b/examples/concomp/HybU.hs deleted file mode 100644 --- a/examples/concomp/HybU.hs +++ /dev/null @@ -1,49 +0,0 @@ -module HybU ( hybrid_connected_components ) -where - -import Data.Array.Parallel.Unlifted - -enumerate :: UArr Bool -> UArr Int -{-# INLINE enumerate #-} -enumerate = scanU (+) 0 . mapU (\b -> if b then 1 else 0) - -pack_index :: UArr Bool -> UArr Int -{-# INLINE pack_index #-} -pack_index bs = mapU fstS . filterU sndS $ zipU (enumFromToU 0 (lengthU bs - 1)) - bs - -shortcut_all :: UArr Int -> UArr Int -shortcut_all p = let pp = bpermuteU p p - in if p == pp then pp else shortcut_all pp - -compress_graph :: UArr Int -> UArr (Int :*: Int) - -> UArr (Int :*: Int) :*: UArr Int -compress_graph p e = - let e1 :*: e2 = unzipU e - e' = zipU (bpermuteU p e1) (bpermuteU p e2) - e'' = mapU (\(i :*: j) -> if i > j then j :*: i else i :*: j) - . filterU (\(i :*: j) -> i /= j) - $ e' - - roots = zipWithU (==) p (enumFromToU 0 (lengthU p - 1)) - labels = enumerate roots - e1'' :*: e2'' = unzipU e'' - e''' = zipU (bpermuteU labels e1'') (bpermuteU labels e2'') - in - e''' :*: pack_index roots - -hybrid_connected_components :: UArr (Int :*: Int) -> Int -> Int :*: UArr Int -{-# NOINLINE hybrid_connected_components #-} -hybrid_connected_components e n - | nullU e = 0 :*: enumFromToU 0 (n-1) - | otherwise = let p = shortcut_all - $ updateU (enumFromToU 0 (n-1)) e - e' :*: i = compress_graph p e - k :*: r = hybrid_connected_components e' (lengthU i) - ins = updateU p - . zipU i - $ bpermuteU i r - in - k+1 :*: bpermuteU ins ins - - diff --git a/examples/concomp/HybUP.hs b/examples/concomp/HybUP.hs deleted file mode 100644 --- a/examples/concomp/HybUP.hs +++ /dev/null @@ -1,51 +0,0 @@ -module HybUP ( hybrid_connected_components ) -where - -import Data.Array.Parallel.Unlifted -import Data.Array.Parallel.Unlifted.Parallel - -enumerate :: UArr Bool -> UArr Int -{-# INLINE enumerate #-} -enumerate = scanUP (+) 0 . mapUP (\b -> if b then 1 else 0) - -pack_index :: UArr Bool -> UArr Int -{-# INLINE pack_index #-} -pack_index bs = mapUP fstS - . filterUP sndS - $ zipU (enumFromToUP 0 (lengthU bs - 1)) - bs - -shortcut_all :: UArr Int -> UArr Int -shortcut_all p = let pp = bpermuteUP p p - in if p == pp then pp else shortcut_all pp - -compress_graph :: UArr Int -> UArr (Int :*: Int) - -> UArr (Int :*: Int) :*: UArr Int -compress_graph p e = - let e1 :*: e2 = unzipU e - e' = zipU (bpermuteUP p e1) (bpermuteUP p e2) - e'' = mapUP (\(i :*: j) -> if i > j then j :*: i else i :*: j) - . filterUP (\(i :*: j) -> i /= j) - $ e' - - roots = zipWithUP (==) p (enumFromToUP 0 (lengthU p - 1)) - labels = enumerate roots - e1'' :*: e2'' = unzipU e'' - e''' = zipU (bpermuteUP labels e1'') (bpermuteUP labels e2'') - in - e''' :*: pack_index roots - -hybrid_connected_components :: UArr (Int :*: Int) -> Int -> Int :*: UArr Int -{-# NOINLINE hybrid_connected_components #-} -hybrid_connected_components e n - | nullU e = 0 :*: enumFromToUP 0 (n-1) - | otherwise = let p = shortcut_all - $ updateUP (enumFromToUP 0 (n-1)) e - e' :*: i = compress_graph p e - k :*: r = hybrid_connected_components e' (lengthU i) - ins = updateUP p - . zipU i - $ bpermuteUP i r - in - k+1 :*: bpermuteUP ins ins - diff --git a/examples/concomp/Makefile b/examples/concomp/Makefile deleted file mode 100644 --- a/examples/concomp/Makefile +++ /dev/null @@ -1,12 +0,0 @@ -TESTDIR = .. -PROGS = mkg concomp -include $(TESTDIR)/mk/test.mk - -ALGS = AwShU.hs AwShUP.hs HybU.hs HybUP.hs - -mkg.o: Graph.hi -mkg: Graph.o - -concomp.o: Graph.hi $(ALGS:.hs=.hi) -concomp: Graph.o $(ALGS:.hs=.o) - diff --git a/examples/concomp/README b/examples/concomp/README deleted file mode 100644 --- a/examples/concomp/README +++ /dev/null @@ -1,26 +0,0 @@ -Connected components in undirected graphs -========================================= - -This benchmark implements the Awerbuch-Shiloach and Hybrid algorithms for -finding connected components in undirected graphs from -http://www.cs.cmu.edu/~scandal/nesl/algorithms.html#concomp - -Generating test data --------------------- - -The utility mkg generates random test graphs. Call it with - - mkg NODES EDGES > FILE - -where NODES and EDGES determine the number of nodes and edges, respectively. - -Running the benchmark ---------------------- - -concomp --help displays the available options. - -The following algorithms are supported: - - awshu, awshup - Awerbuch-Shiloach (sequential and parallel version) - hybu, hybup - Hybrid (sequential and parallel version) - diff --git a/examples/concomp/concomp.hs b/examples/concomp/concomp.hs deleted file mode 100644 --- a/examples/concomp/concomp.hs +++ /dev/null @@ -1,57 +0,0 @@ -import Data.Array.Parallel.Unlifted -import Data.Array.Parallel.Unlifted.Distributed -import Graph -import qualified AwShU -import qualified AwShUP -import qualified HybU -import qualified HybUP - -import System.Console.GetOpt -import System.IO -import Control.Exception (evaluate) - -import Bench.Benchmark -import Bench.Options - - -type Alg = UArr (Int :*: Int) -> Int -> Int :*: UArr Int - -algs = [("awshu", AwShU.aw_connected_components) - ,("awshup", AwShUP.aw_connected_components) - ,("hybu", HybU.hybrid_connected_components) - ,("hybup", HybUP.hybrid_connected_components) - ] - -main = ndpMain "Connected components" - "[OPTION] ... FILES ..." - run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") - "use the specified algorithm"] - "" - -run opts alg files = - case lookup alg algs of - Just f -> procFiles opts f files - Nothing -> failWith ["Unknown algorithm " ++ alg] - -procFiles :: Options -> Alg -> [String] -> IO () -procFiles opts alg fs = - do - benchmark opts (uncurry alg) - (map load $ files fs) - showRes - return () - where - files [] = [""] - files fs = fs - - showRes (r :*: _) = "d=" ++ show r - -load :: String -> IO (Point (UArr (Int :*: Int), Int)) -load fname = - do - g <- loadGraph fname - evaluate (edges g) - return $ mkPoint ( "n=" ++ show (nodeCount g) ++ ", " - ++ "e=" ++ show (edgeCount g)) - (edges g, nodeCount g) - diff --git a/examples/concomp/mkg.hs b/examples/concomp/mkg.hs deleted file mode 100644 --- a/examples/concomp/mkg.hs +++ /dev/null @@ -1,55 +0,0 @@ -import Data.Array.ST -import Data.Array -import System.Random -import System.IO -import System.Exit -import System.Environment - -import Data.Array.Parallel.Unlifted -import Graph - -randomG :: RandomGen g => g -> Int -> Int -> Graph -randomG g n e = Graph n e ues - where - aes = runSTArray (do - arr <- newArray (0,n-1) [] - fill arr (randomRs (0,n-1) g) e - ) - - fill arr _ 0 = return arr - fill arr (m:n:rs) e = - let lo = min m n - hi = max m n - in - do - ns <- readArray arr lo - if lo == hi || hi `elem` ns - then fill arr rs e - else do - writeArray arr lo (hi : ns) - fill arr rs (e-1) - - - ues = toU $ concat [map (m :*:) ns | (m,ns) <- assocs aes] - -main = do - args <- getArgs - (n,e,file) <- parseArgs args - g <- newStdGen - storeGraph file $ randomG g n e - where - parseArgs [nodes,edges,file] = - do - n <- parseInt nodes - e <- parseInt edges - return (n,e,file) - parseArgs _ = do - hPutStrLn stderr "Invalid arguments" - exitFailure - - parseInt s = case reads s of - ((n,_) : _) -> return n - _ -> do - hPutStrLn stderr $ "Invalid argument " ++ s - exitFailure - diff --git a/examples/dotp/DotPPar.hs b/examples/dotp/DotPPar.hs deleted file mode 100644 --- a/examples/dotp/DotPPar.hs +++ /dev/null @@ -1,9 +0,0 @@ -module DotPPar where - -import Data.Array.Parallel.Unlifted -import Data.Array.Parallel.Unlifted.Parallel - -dotp :: UArr Double -> UArr Double -> Double -{-# NOINLINE dotp #-} -dotp v w = sumUP (zipWithUP (*) v w) - diff --git a/examples/dotp/DotPSeq.hs b/examples/dotp/DotPSeq.hs deleted file mode 100644 --- a/examples/dotp/DotPSeq.hs +++ /dev/null @@ -1,8 +0,0 @@ -module DotPSeq where - -import Data.Array.Parallel.Unlifted - -dotp :: UArr Double -> UArr Double -> Double -{-# NOINLINE dotp #-} -dotp v w = sumU (zipWithU (*) v w) - diff --git a/examples/dotp/DotPVect.hs b/examples/dotp/DotPVect.hs deleted file mode 100644 --- a/examples/dotp/DotPVect.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE PArr #-} -{-# OPTIONS -fvectorise #-} -module DotPVect where - -import Data.Array.Parallel.Prelude -import Data.Array.Parallel.Prelude.Double - -import qualified Prelude - -dotp :: PArray Double -> PArray Double -> Double -{-# NOINLINE dotp #-} -dotp v w = dotp' (fromPArrayP v) (fromPArrayP w) - -dotp' :: [:Double:] -> [:Double:] -> Double -dotp' v w = sumP (zipWithP (*) v w) - diff --git a/examples/dotp/Makefile b/examples/dotp/Makefile deleted file mode 100644 --- a/examples/dotp/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -TESTDIR = .. -PROGS = dotp -include $(TESTDIR)/mk/test.mk - -dotp.o: DotPSeq.hi DotPPar.hi DotPVect.hi - -dotp: DotPSeq.o DotPPar.o DotPVect.o $(BENCHLIB) - diff --git a/examples/dotp/README b/examples/dotp/README deleted file mode 100644 --- a/examples/dotp/README +++ /dev/null @@ -1,11 +0,0 @@ -Dot product -=========== - -dotp --help displays the available options. - -The following algorithms are supported: - - seq - sequential implementation - par - parallel implementation - vect - vectorised implementation - diff --git a/examples/dotp/dotp.hs b/examples/dotp/dotp.hs deleted file mode 100644 --- a/examples/dotp/dotp.hs +++ /dev/null @@ -1,65 +0,0 @@ -import qualified DotPSeq -import qualified DotPPar -import qualified DotPVect - -import Control.Exception (evaluate) -import System.Console.GetOpt -import System.Random - -import Data.Array.Parallel.Prelude (fromUArrPA') -import Data.Array.Parallel.Unlifted -import Data.Array.Parallel.Unlifted.Distributed - -import Bench.Benchmark -import Bench.Options - -algs = [("par", DotPPar.dotp) - ,("seq", DotPSeq.dotp) - ,("list", dotp_list) - ,("vect", dotp_vect)] - -type Vector = UArr Double - -dotp_vect :: Vector -> Vector -> Double -dotp_vect xs ys = DotPVect.dotp (fromUArrPA' xs) (fromUArrPA' ys) - - -dotp_list:: Vector -> Vector -> Double -dotp_list xs ys = sum $ zipWith (*) (fromU xs) (fromU ys) --- generates a random vector of the given length in NF --- -generateVector :: Int -> IO Vector -generateVector n = - do - rg <- newStdGen - let fs = take n $ randomRs (-100, 100) rg - vec = toU fs - evaluate vec - return vec - -generateVectors :: Int -> IO (Point (Vector, Vector)) -generateVectors n = - do - v <- generateVector n - w <- generateVector n - return $ ("N = " ++ show n) `mkPoint` (v,w) - - -main = ndpMain "Dot product" - "[OPTION] ... SIZES ..." - run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") - "use the specified algorithm"] - "par" - -run opts alg sizes = - case lookup alg algs of - Nothing -> failWith ["Unknown algorithm"] - Just f -> case map read sizes of - [] -> failWith ["No sizes specified"] - szs -> do - benchmark opts (uncurry f) - (map generateVectors szs) - show - return () - - diff --git a/examples/fusion/DotP.hs b/examples/fusion/DotP.hs deleted file mode 100644 --- a/examples/fusion/DotP.hs +++ /dev/null @@ -1,8 +0,0 @@ -module DotP where -import Data.Array.Vector - --- > 1 loopU/loopU - -dotp :: UArr Double -> UArr Double -> Double -dotp v w = sumU (zipWithU (*) v w) - diff --git a/examples/fusion/Map_Map.hs b/examples/fusion/Map_Map.hs deleted file mode 100644 --- a/examples/fusion/Map_Map.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Map_Map where -import Data.Array.Vector - --- > 1 loopU/loopU - -map_map :: (Int -> Int) -> (Int -> Int) -> UArr Int -> UArr Int -map_map f g = mapU f . mapU g - diff --git a/examples/fusion/Map_Map_Replicate.hs b/examples/fusion/Map_Map_Replicate.hs deleted file mode 100644 --- a/examples/fusion/Map_Map_Replicate.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Map_Map_Replicate where -import Data.Array.Vector - --- > 2 loopU/loopU - -map_map_replicate :: (UA a, UA b, UA c) - => (b -> c) -> (a -> b) -> Int -> a -> UArr c -map_map_replicate f g n = mapU f . mapU g . replicateU n - diff --git a/examples/fusion/Map_Replicate.hs b/examples/fusion/Map_Replicate.hs deleted file mode 100644 --- a/examples/fusion/Map_Replicate.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Map_Replicate where -import Data.Array.Vector - --- > 1 loopU/loopU - -map_replicate :: (UA a, UA b) => (a -> b) -> Int -> a -> UArr b -map_replicate f n = mapU f . replicateU n - diff --git a/examples/fusion/runtst.sh b/examples/fusion/runtst.sh deleted file mode 100644 --- a/examples/fusion/runtst.sh +++ /dev/null @@ -1,52 +0,0 @@ -#! /bin/bash - -GHC=ghc -OPTS="--make\ - -fglasgow-exts -O2 -funbox-strict-fields\ - -fliberate-case-threshold100 -fno-method-sharing" - -verbose=yes -tests= - -exec 6> /dev/null - -for arg -do - case $arg in - --verbose|-v) exec 6>&1 - ;; - *) tests="$tests $arg" - ;; - esac -done - -tests=${tests:=`ls *.hs`} - -for file in $tests -do - echo Testing $file >&6 - rules=`sed -n 's/-- >[[:space:]]*\([0-9]\+\)[[:space:]]\+\([^[:space:]]\+\)/\1 \2/p' $file` - log=`echo $file | sed 's/\.hs$/.log/'` - echo "$GHC $OPTS -c $file -ddump-simpl-stats" >&6 - if $GHC $OPTS -c $file -ddump-simpl-stats > $log - then - oldIFS=$IFS - IFS=' -' - for rule in `sed -n 's/-- >[[:space:]]*\([0-9]\+\)[[:space:]]\+\([^[:space:]]\+\)/\1 \2/p' $file` - do - if ! grep "$rule" $log > /dev/null 2>&1 - then - echo "FAIL: $file ($rule)" - break - else - echo "OK" - fi - done - IFS=$oldIFS - else - echo FAIL: $file - compiler error - fi -done -rm -f *.hi *.o - diff --git a/examples/lib/Bench/Benchmark.hs b/examples/lib/Bench/Benchmark.hs deleted file mode 100644 --- a/examples/lib/Bench/Benchmark.hs +++ /dev/null @@ -1,114 +0,0 @@ -module Bench.Benchmark -where - -import Bench.Time (Time, getTime) -import qualified Bench.Time as T - -import Bench.Options (Options(..)) - -import System.IO -import System.Mem (performGC) - -newtype Timing a = Timing [(a, Time)] - -time :: IO a -> IO (a, Time) -{-# NOINLINE time #-} -time p = do - start <- getTime - x <- p - end <- getTime - return (x, end `T.minus` start) - -time_ :: IO a -> IO Time -time_ = fmap snd . time - -timeFn :: (a -> b) -> a -> IO (b, Time) -{-# NOINLINE timeFn #-} -timeFn f x = time (return $! f x) - -timeFn_ :: (a -> b) -> a -> IO Time -timeFn_ f = fmap snd . timeFn f - -showTime :: Time -> String -showTime t = (show $ T.wallTime T.milliseconds t) - ++ "/" - ++ (show $ T.cpuTime T.milliseconds t) - -showTimes :: [Time] -> String -showTimes ts = unwords [ showTime (T.minimum ts) - , showTime (T.average ts) - , showTime (T.maximum ts) - ] - -type Msg a = a -> [(Int -> Bool, IO ())] - -say :: String -> IO () -say s = do - hPutStr stdout s - hFlush stdout - -sayLn :: String -> IO () -sayLn s = do - hPutStrLn stdout s - hFlush stdout - -msgRun :: Msg Int -msgRun n = [((==2), say ".") - ,((>2), say $ " run " ++ show n ++ ": ")] - -msgResult :: Msg (Time, String) -msgResult (t,s) = [((==3), sayLn $ showTime t) - ,((>3), sayLn $ showTime t ++ " (" ++ s ++ ")")] - -msgPoint :: Msg String -msgPoint s = [((==1), say $ s ++ ": ") - ,((==2), say $ s ++ " ") - ,((>2), sayLn $ s ++ " ...")] - -msgTiming :: Msg String -msgTiming s = [((==1), sayLn s) - ,((==2), sayLn $ " " ++ s) - ,((>2), sayLn $ "... " ++ s)] - -message :: Msg a -> Options -> a -> IO () -message msg opts x = case [p | (f,p) <- msg x, f (optVerbosity opts)] of - [] -> return () - (p:_) -> p - -benchmark' :: Options -> (a -> b) -> a -> (b -> String) -> IO [Time] -benchmark' opts f x outp = sequence $ map bench1 [1 .. optRuns opts] - where - bench1 n = - do - message msgRun opts n - performGC - (x, t) <- timeFn f x - message msgResult opts (t, outp x) - return t - -data Point a = Point String a - -point :: Show a => a -> Point a -point = labelPoint show - -labelPoint :: (a -> String) -> a -> Point a -labelPoint f x = Point (f x) x - -mkPoint :: String -> a -> Point a -mkPoint s x = Point s x - -benchmark :: Options - -> (a -> b) - -> [IO (Point a)] - -> (b -> String) - -> IO [[Time]] -benchmark o f ps outp = mapM bench1 ps - where - bench1 p = - do - Point s x <- p - message msgPoint o s - ts <- benchmark' o f x outp - message msgTiming o $ showTimes ts - return ts - diff --git a/examples/lib/Bench/Options.hs b/examples/lib/Bench/Options.hs deleted file mode 100644 --- a/examples/lib/Bench/Options.hs +++ /dev/null @@ -1,84 +0,0 @@ -module Bench.Options ( - Options(..), - ndpMain, failWith -) where - -import System.Console.GetOpt -import System.IO -import System.Exit -import System.Environment - -import Data.Array.Parallel.Unlifted.Distributed - -data Options = Options { optRuns :: Int - , optVerbosity :: Int - , optSetGang :: IO () - , optHelp :: Bool - } - -defaultVerbosity :: Int -defaultVerbosity = 1 - -defaultOptions :: Options -defaultOptions = Options { optRuns = 1 - , optVerbosity = defaultVerbosity - , optSetGang = setSequentialGang 1 - , optHelp = False - } - -options = [Option ['r'] ["runs"] - (ReqArg (\s o -> o { optRuns = read s }) "N") - "repeat each benchmark N times" - ,Option ['v'] ["verbose"] - (OptArg (\r o -> o { optVerbosity = maybe defaultVerbosity read r }) - "N") - "verbosity level" - ,Option ['t'] ["threads"] - (ReqArg (\s o -> o { optSetGang = setGang (read s)}) "N") - "use N threads" - ,Option ['s'] ["seq"] - (OptArg (\r o -> o { optSetGang = setSequentialGang - (maybe 1 read r) }) "N") - "simulate N threads (default 1)" - ,Option ['h'] ["help"] - (NoArg (\o -> o { optHelp = True })) - "show help screen" - ] - -instance Functor OptDescr where - fmap f (Option c s d h) = Option c s (fmap f d) h - -instance Functor ArgDescr where - fmap f (NoArg x) = NoArg (f x) - fmap f (ReqArg g s) = ReqArg (f . g) s - fmap f (OptArg g s) = OptArg (f . g) s - -ndpMain :: String -> String - -> (Options -> a -> [String] -> IO ()) - -> [OptDescr (a -> a)] -> a - -> IO () -ndpMain descr hdr run options' dft = - do - args <- getArgs - case getOpt Permute opts args of - (fs, files, []) -> - let (os, os') = foldr ($) (defaultOptions, dft) fs - in - if optHelp os - then do - s <- getProgName - putStrLn $ usageInfo ("Usage: " ++ s ++ " " ++ hdr ++ "\n" - ++ descr ++ "\n") opts - else do - optSetGang os - run os os' files - (_, _, errs) -> failWith errs - where - opts = [fmap (\f (r,s) -> (f r, s)) d | d <- options] - ++ [fmap (\f (r,s) -> (r, f s)) d | d <- options'] - -failWith :: [String] -> IO a -failWith errs = do - mapM_ (hPutStrLn stderr) errs - exitFailure - diff --git a/examples/lib/Bench/Time.hs b/examples/lib/Bench/Time.hs deleted file mode 100644 --- a/examples/lib/Bench/Time.hs +++ /dev/null @@ -1,96 +0,0 @@ -module Bench.Time ( - Time, - getTime, - wallTime, cpuTime, - picoseconds, milliseconds, seconds, - - minus, plus, div, - min, max, avg, - sum, minimum, maximum, average -) where - -import System.CPUTime -import System.Time - -import Prelude hiding( div, min, max, sum, minimum, maximum ) -import qualified Prelude as P - -infixl 6 `plus`, `minus` -infixl 7 `div` - -data Time = Time { cpu_time :: Integer - , wall_time :: Integer - } - -type TimeUnit = Integer -> Integer - -picoseconds :: TimeUnit -picoseconds = id - -milliseconds :: TimeUnit -milliseconds n = n `P.div` 1000000000 - -seconds :: TimeUnit -seconds n = n `P.div` 1000000000000 - -cpuTime :: TimeUnit -> Time -> Integer -cpuTime f = f . cpu_time - -wallTime :: TimeUnit -> Time -> Integer -wallTime f = f . wall_time - -getTime :: IO Time -getTime = - do - cpu <- getCPUTime - TOD sec pico <- getClockTime - return $ Time cpu (pico + sec * 1000000000000) - -{- -timeIO :: IO a -> IO (a, Time) -timeIO p = do - start <- getTime - x <- p - end <- getTime - return (x, end `minusT` start) - -timeIO_ :: IO () -> IO Time -timeIO_ = fmap snd . timeIO --} - -zipT :: (Integer -> Integer -> Integer) -> Time -> Time -> Time -zipT f (Time cpu1 wall1) (Time cpu2 wall2) = - Time (f cpu1 cpu2) (f wall1 wall2) - -minus :: Time -> Time -> Time -minus = zipT (-) - -plus :: Time -> Time -> Time -plus = zipT (+) - -div :: Time -> Int -> Time -div (Time cpu clock) n = Time (cpu `P.div` n') (clock `P.div` n') - where - n' = toInteger n - -min :: Time -> Time -> Time -min = zipT P.min - -max :: Time -> Time -> Time -max = zipT P.max - -avg :: Time -> Time -> Time -avg t1 t2 = (t1 `plus` t2) `div` 2 - -sum :: [Time] -> Time -sum = foldr1 plus - -minimum :: [Time] -> Time -minimum = foldr1 min - -maximum :: [Time] -> Time -maximum = foldr1 max - -average :: [Time] -> Time -average ts = sum ts `div` length ts - diff --git a/examples/lib/Makefile b/examples/lib/Makefile deleted file mode 100644 --- a/examples/lib/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -TESTDIR=.. -include $(TESTDIR)/mk/common.mk - -HCFLAGS = -O -package ndp - -.PHONY: clean all - -all: libNDPBench.a - -clean: - -$(RM) Bench/*.o Bench/*.hi libNDPBench.a - -libNDPBench.a: Bench/Benchmark.o Bench/Time.o Bench/Options.o - $(RM) $@ - $(AR) q $@ $^ - -%.o: %.hs - $(HC) -c $< $(HCFLAGS) $(FLAGS) - -%.hi: %.o - @: - -Bench/Benchmark.o: Bench/Time.hi Bench/Options.hi - - diff --git a/examples/mk/common.mk b/examples/mk/common.mk deleted file mode 100644 --- a/examples/mk/common.mk +++ /dev/null @@ -1,10 +0,0 @@ -NDPDIR = $(TESTDIR)/.. -NDPVERSION = 0.1 -BENCHDIR = $(TESTDIR)/lib - -NDPLIB = $(NDPDIR)/dist/build/libHSndp-$(NDPVERSION).a -BENCHLIB = $(BENCHDIR)/libNDPBench.a -HC = $(NDPDIR)/../../compiler/ghc-inplace - -include $(NDPDIR)/ndp.mk - diff --git a/examples/mk/test.mk b/examples/mk/test.mk deleted file mode 100644 --- a/examples/mk/test.mk +++ /dev/null @@ -1,29 +0,0 @@ -include $(TESTDIR)/mk/common.mk -HCFLAGS = $(NDPFLAGS) $(TESTFLAGS) -package ndp -no-recomp -i$(BENCHDIR) -HLDFLAGS += -L$(BENCHDIR) -lNDPBench - -.PHONY: clean all bench - -all: bench $(PROGS) - -clean: - -$(RM) *.hi *.o $(PROGS) - -%.o: %.hs $(NDPLIB) $(BENCHLIB) - $(HC) -c $< $(HCFLAGS) $(FLAGS) - -%.o: %.c - $(HC) -c $< $(HCCFLAGS) $(FLAGS) - -%: %.c - $(HC) -o $@ $(HCCFLAGS) $^ $(HLDFLAGS) - -%: %.o - $(HC) -o $@ $(HCFLAGS) $^ $(HLDFLAGS) - -%.hi: %.o - @: - -bench: - cd $(BENCHDIR) && $(MAKE) - diff --git a/examples/primes/H98.hs b/examples/primes/H98.hs deleted file mode 100644 --- a/examples/primes/H98.hs +++ /dev/null @@ -1,19 +0,0 @@ -module H98 -where - -import Data.Array - -primes :: Int -> [Int] -{-# NOINLINE primes #-} -primes n - | n <= 2 = [] - | otherwise = - let - sqrPrimes = primes (ceiling (sqrt (fromIntegral n))) - sieves = concat - [[2 * p, 3 * p..n - 1] | p <- sqrPrimes] - sieves' = zip sieves (repeat False) - flags = accumArray (&&) True (0, n - 1) sieves' - in - drop 2 (filter (flags!) [0..n - 1]) - diff --git a/examples/primes/Makefile b/examples/primes/Makefile deleted file mode 100644 --- a/examples/primes/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -TESTDIR = .. -PROGS = primes -include $(TESTDIR)/mk/test.mk - -primes.o: H98.hi PrimSeq.hi PrimPar.hi - -primes: H98.o PrimSeq.o PrimPar.o - diff --git a/examples/primes/PrimPar.hs b/examples/primes/PrimPar.hs deleted file mode 100644 --- a/examples/primes/PrimPar.hs +++ /dev/null @@ -1,32 +0,0 @@ -module PrimPar --- --- TODO: --- bpermuteDftU which does most of the work is still sequential - -where - -import Data.Array.Parallel.Unlifted.Distributed -import Data.Array.Parallel.Unlifted.Parallel -import Data.Array.Parallel.Unlifted - - -import Debug.Trace -primes :: Int -> UArr Int -{-# NOINLINE primes #-} -primes n - | n <= 2 = emptyU - | otherwise = - let - sqrPrimes = primes (ceiling (sqrt (fromIntegral n))) - sieves = concatSU $ - enumFromThenToSUP - (mapUP (*2) sqrPrimes) - (mapUP (*3) sqrPrimes) - (replicateUP (lengthU sqrPrimes) (n - 1)) - sieves' = zipU sieves (replicateUP (lengthU sieves) False) - flags = bpermuteDftU n (const True) sieves' - arg = flags `seq` (filterUP (flags!:) (enumFromToUP 0 (n - 1))) - in - dropUP 2 arg - - diff --git a/examples/primes/PrimSeq.hs b/examples/primes/PrimSeq.hs deleted file mode 100644 --- a/examples/primes/PrimSeq.hs +++ /dev/null @@ -1,22 +0,0 @@ -module PrimSeq -where - -import Data.Array.Parallel.Unlifted - -primes :: Int -> UArr Int -{-# NOINLINE primes #-} -primes n - | n <= 2 = emptyU - | otherwise = - let - sqrPrimes = primes (ceiling (sqrt (fromIntegral n))) - sieves = concatSU $ - enumFromThenToSU - (mapU (*2) sqrPrimes) - (mapU (*3) sqrPrimes) - (replicateU (lengthU sqrPrimes) (n - 1)) - sieves' = zipU sieves (replicateU (lengthU sieves) False) - flags = bpermuteDftU n (const True) sieves' - in - dropU 2 (filterU (flags!:) (enumFromToU 0 (n - 1))) - diff --git a/examples/primes/README b/examples/primes/README deleted file mode 100644 --- a/examples/primes/README +++ /dev/null @@ -1,13 +0,0 @@ -Sieve of Eratosthenes -===================== - -primes --help displays the available options. - -The following algorithms are supported: - - h98 - implementation based on standard Haskell arrays - seq - sequential implementation with UArrs - -No parallel implementation is available yet as the library is missing -functionality. - diff --git a/examples/primes/primes.hs b/examples/primes/primes.hs deleted file mode 100644 --- a/examples/primes/primes.hs +++ /dev/null @@ -1,42 +0,0 @@ -import Control.Exception (evaluate) -import System.Console.GetOpt - -import Data.Array.Parallel.Unlifted - -import Bench.Benchmark -import Bench.Options - -import qualified H98 -import qualified PrimSeq -import qualified PrimPar - -type Alg = Int -> () - -seqList :: [Int] -> () -seqList [] = () -seqList (x:xs) = x `seq` seqList xs - -algs = [("h98", seqList . H98.primes) - ,("seq", \n -> PrimSeq.primes n `seq` ()) - ,("par", \n -> PrimPar.primes n `seq` ()) - ] - -main = ndpMain "Sieve of Eratosthenes" - "[OPTION] ... N ..." - run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") - "use the specified algorithm"] - "seq" - -run opts alg sizes = - case lookup alg algs of - Nothing -> failWith ["Unknown algorithm " ++ alg] - Just f -> case map read sizes of - [] -> failWith ["No sizes specified"] - ns -> do - benchmark opts f - (map (return . labelPoint showN) ns) - (const "") - return () - where - showN n = "N=" ++ show n - diff --git a/examples/primespj/Primes.hs b/examples/primespj/Primes.hs deleted file mode 100644 --- a/examples/primespj/Primes.hs +++ /dev/null @@ -1,63 +0,0 @@ -module Main where - - -import Control.Exception (evaluate) -import System.Console.GetOpt - -import Data.Array.Parallel.Unlifted -import Data.Array.Parallel.Unlifted.Parallel - -import Bench.Benchmark -import Bench.Options -import Data.Array.Parallel.Prelude (toUArrPA, fromUArrPA_3') - - -import PrimesVect (primesVect) -import Debug.Trace - - -algs = [("list", primesList), ("vect", primesVect')] - -primesList:: Int -> UArr Int -primesList n = trace (show res) res - where - res = toU $ primesList' n - -primesList' :: Int -> [Int] -primesList' 1 = [] -primesList' n = sps ++ [ i | i <- [sq+1..n], multiple sps i ] - where - sps = primesList' sq - sq = floor $ sqrt $ fromIntegral n - - multiple :: [Int] -> Int -> Bool - multiple ps i = and [i `mod` p /= 0 | p <- ps] - -primesVect':: Int -> UArr Int -primesVect' n = toUArrPA (primesVect n) - - -simpleTest:: Int -> IO (Bench.Benchmark.Point ( Int)) -simpleTest n = - do - evaluate testData - return $ ("N = " ) `mkPoint` testData - where - testData:: Int - testData = n - -main = ndpMain "Primes" - "[OPTION] ... SIZES ..." - run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") - "use the specified algorithm"] - "list" - - -run opts alg sizes = - case lookup alg algs of - Nothing -> failWith ["Unknown algorithm"] - Just f -> case map read sizes of - [] -> failWith ["No sizes specified"] - ([szs]::[Int]) -> do - benchmark opts f [simpleTest szs] show - return () diff --git a/examples/primespj/PrimesVect.hs b/examples/primespj/PrimesVect.hs deleted file mode 100644 --- a/examples/primespj/PrimesVect.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE PArr #-} -{-# GHC_OPTIONS -fglasgow-exts #-} -{-# OPTIONS -fvectorise #-} -{-# OPTIONS -fno-spec-constr-count #-} -module PrimesVect (primesVect) - -where -import Data.Array.Parallel.Prelude -import Data.Array.Parallel.Prelude.Int -import qualified Prelude - - -primesVect:: Int -> PArray Int -primesVect n = toPArrayP (primesVect' n) - -primesVect':: Int -> [:Int:] -primesVect' n - | n == 1 = emptyP - | n == 2 = singletonP 2 - | otherwise = sps +:+ [: i | i <- enumFromToP (sq+1) n, notMultiple sps i :] - where - sps = primesVect' sq - sq = intSquareRoot n - - notMultiple :: [:Int:] -> Int -> Bool - notMultiple ps i = andP [: mod i p /= 0 | p <- ps:] diff --git a/examples/qsort/Makefile b/examples/qsort/Makefile deleted file mode 100644 --- a/examples/qsort/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -TESTDIR = .. -PROGS = QSort -HCCFLAGS = -optc-O3 -include $(TESTDIR)/mk/test.mk - -QSort.o: QSortPar.hi QSortSeq.hi QSortVect.hi - -QSort: QSort.o QSortPar.o QSortSeq.o QSortVect.o diff --git a/examples/qsort/QSort.hs b/examples/qsort/QSort.hs deleted file mode 100644 --- a/examples/qsort/QSort.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# OPTIONS -fno-spec-constr-count #-} -module Main where -import QSortSeq -import QSortPar -import QSortVect - -import Control.Exception (evaluate ) -import System.Console.GetOpt - -import Data.Array.Parallel.Unlifted -import Data.Array.Parallel.Unlifted.Parallel -import Data.Array.Parallel.Prelude (toUArrPA, fromUArrPA') - -import Bench.Benchmark -import Bench.Options - -import Debug.Trace - -algs = [("seq", qsortSeq), ("par", qsortPar), ("list", toU. qsortList . fromU), ("vect", qsortVect')] - - - -qsortVect':: UArr Double -> UArr Double -qsortVect' xs = -- trace (show res) - res - where - res = toUArrPA $ qsortVect $ fromUArrPA' xs - - -generateVector :: Int -> IO (Point (UArr Double)) -generateVector n = - do - evaluate vec - return $ ("N = " ++ show n) `mkPoint` vec - where - vec = toU (reverse [1..fromInteger (toInteger n)]) - -main = ndpMain "QSort" - "[OPTION] ... SIZES ..." - run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") - "use the specified algorithm"] - "seq" - -run opts alg sizes = - case lookup alg algs of - Nothing -> failWith ["Unknown algorithm"] - Just f -> case map read sizes of - [] -> failWith ["No sizes specified"] - szs -> do - benchmark opts f (map generateVector szs) show - return () - diff --git a/examples/qsort/QSortPar.hs b/examples/qsort/QSortPar.hs deleted file mode 100644 --- a/examples/qsort/QSortPar.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# GHC_OPTIONS -fglasgow-exts #-} -{-# OPTIONS -fno-spec-constr-count #-} --- --- TODO: --- permute operations, which are fairly important for this algorithm, are currently --- all sequential - -module QSortPar (qsortPar) -where - -import Data.Array.Parallel.Unlifted.Distributed -import Data.Array.Parallel.Unlifted.Parallel -import Data.Array.Parallel.Unlifted -import Debug.Trace - --- I'm lazy here and use the lifted qsort instead of writing a flat version -qsortPar :: UArr Double -> UArr Double -{-# NOINLINE qsortPar #-} -qsortPar = concatSU . qsortLifted . singletonSU - - --- Remove the trivially sorted segments -qsortLifted:: SUArr Double -> SUArr Double -qsortLifted xssArr = - splitApplySUP flags qsortLifted' id xssArr - where - flags = mapUP ((> 1)) $ lengthsSU xssArr - --- Actual sorting -qsortLifted' xssarr = - if (xssLen == 0) - then xssarr - else (takeCU xssLen sorted) ^+:+^ equal ^+:+^ (dropCU xssLen sorted) - - where - - xssLen = lengthSU xssarr - xsLens = lengthsSU xssarr - pivots = xssarr !:^ mapUP (flip div 2) xsLens - pivotss = replicateSUP xsLens pivots - xarrLens = zipSU xssarr pivotss - sorted = qsortLifted (smaller +:+^ greater) - smaller = fstSU $ filterSUP (uncurryS (<)) xarrLens - greater = fstSU $ filterSUP (uncurryS (>)) xarrLens - equal = fstSU $ filterSUP (uncurryS (==)) xarrLens - - - -splitApplySUP:: (UA e, UA e', Show e, Show e') => - UArr Bool -> (SUArr e -> SUArr e') -> (SUArr e -> SUArr e') -> SUArr e -> SUArr e' -{-# INLINE splitApplySUP #-} -splitApplySUP flags f1 f2 xssArr = - if (lengthSU xssArr == 0) - then segmentArrU emptyU emptyU - else combineCU flags res1 res2 - - where - res1 = f1 $ packCUP flags xssArr - res2 = f2 $ packCUP (mapUP not flags) xssArr - - - - - diff --git a/examples/qsort/QSortSeq.hs b/examples/qsort/QSortSeq.hs deleted file mode 100644 --- a/examples/qsort/QSortSeq.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# GHC_OPTIONS -fglasgow-exts #-} -{-# OPTIONS -fno-spec-constr-count #-} --- - -module QSortSeq (qsortSeq, qsortList) -where - -import Data.Array.Parallel.Unlifted -import Debug.Trace - - -qsortSeq :: UArr Double -> UArr Double -qsortSeq xs = -- trace (show res) - res - where - res = concatSU $ qsortLifted $ singletonSU xs - -qsortLifted:: SUArr Double -> SUArr Double -qsortLifted xssArr = splitApplySU flags qsortLifted' id xssArr - where - flags = mapU ((>=1)) $ lengthsSU xssArr - -qsortLifted' xssarr = - if (xssLen == 0) - then xssarr - else (takeCU xssLen sorted) ^+:+^ equal ^+:+^ (dropCU xssLen sorted) - where - xssLen = lengthSU xssarr - xsLens = lengthsSU xssarr - xarrLens = zipSU xssarr $ replicateSU xsLens $ xssarr !:^ mapU (flip div 2) xsLens - sorted = qsortLifted $ (mapSU fstS $ filterSU (uncurryS (<)) xarrLens) - +:+^ - (mapSU fstS $ filterSU (uncurryS (>)) xarrLens) - equal = mapSU fstS $ filterSU (uncurryS (==)) xarrLens - - -splitApplySU:: (UA e, UA e', Show e, Show e') => UArr Bool -> (SUArr e -> SUArr e') -> (SUArr e -> SUArr e') -> SUArr e -> SUArr e' -{-# INLINE splitApplySU #-} -splitApplySU flags f1 f2 xssArr = res - - where - res = combineCU flags res1 res2 - res1 = f1 $ packCU flags xssArr - res2 = f2 $ packCU (mapU not flags) xssArr - - -qsortList:: [Double] -> [Double] -qsortList = qsortList' - -qsortList' [] = [] -qsortList' xs = (qsortList' smaller) ++ equal ++ (qsortList' greater) - where - p = xs !! (length xs `div` 2) - smaller = [x | x <- xs, x < p] - equal = [x | x <- xs, x == p] - greater = [x | x <- xs, x > p] diff --git a/examples/qsort/QSortVect.hs b/examples/qsort/QSortVect.hs deleted file mode 100644 --- a/examples/qsort/QSortVect.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE PArr #-} -{-# OPTIONS -fvectorise #-} -{-# OPTIONS -fno-spec-constr-count #-} -module QSortVect (qsortVect) where - -import Data.Array.Parallel.Prelude -import Data.Array.Parallel.Prelude.Double -import qualified Data.Array.Parallel.Prelude.Int as I - -import qualified Prelude - -qsortVect:: PArray Double -> PArray Double -qsortVect xs = toPArrayP (qsortVect' (fromPArrayP xs)) - -qsortVect':: [: Double :] -> [: Double :] -qsortVect' xs | lengthP xs I.<= 1 = xs - | otherwise = qsortVect' [:x | x <- xs, x < p:] +:+ - [:x | x <- xs, x == p:] +:+ - qsortVect' [:x | x <- xs, x > p:] - where p = (xs !: (lengthP xs `I.div` 2)) diff --git a/examples/quickcheck/Makefile b/examples/quickcheck/Makefile deleted file mode 100644 --- a/examples/quickcheck/Makefile +++ /dev/null @@ -1,68 +0,0 @@ -GHC = ../../../../../../../compiler/stage2/ghc-inplace -NDPDIR = ../../../../.. -NDPLIB = $(NDPDIR)/libHSndp.a - -HC = $(GHC) -HCFLAGS = -fglasgow-exts -package QuickCheck -package template-haskell \ - -i$(NDPDIR) -v0 -OPTFLAGS = -O2 -funbox-strict-fields \ - -fliberate-case-threshold100 -fno-method-sharing - - -TESTSUITE = Testsuite/Utils.hs \ - Testsuite/Testcase.hs \ - Testsuite/Preproc.hs \ - Testsuite.hs - -TESTSUITE_OBJS = $(TESTSUITE:.hs=.o) - -TESTS = $(wildcard tests/*.hs) -TEST_MODS = $(notdir $(TESTS)) -OPT = $(TEST_MODS:.hs=-opt) -UNOPT = $(TEST_MODS:.hs=-unopt) -# we want the tests to be run in the right order -ALL = $(TEST_MODS:.hs=-all) - -TESTMAIN = 'System.Environment.withArgs (words "$(run)") main' - -.PHONY: default unopt opt all testsuite - -default: unopt - -all: $(ALL) - -unopt: $(UNOPT) - -opt: $(OPT) - -testsuite: $(TESTSUITE_OBJS) - -Testsuite.o: $(filter-out Testsuite.o,$(TESTSUITE_OBJS)) - -%.o : %.hs $(NDPLIB) - $(HC) -c $< $(HCFLAGS) - -%-opt.o: %.hs $(NDPLIB) testsuite - $(HC) -o $@ -c $< $(HCFLAGS) $(OPTFLAGS) - -%.hi: %.o - @: - -$(TEST_OBJS) : testsuite - -%-all: %-unopt %-opt - @: - -%-unopt: - @echo "======== Testing $(patsubst %-unopt,%,$@) (interpreted) ========" - @$(HC) -e $(TESTMAIN) $(patsubst %-unopt,tests/%.hs,$@) $(HCFLAGS) \ - | tee $@.log | { grep -v '\.\.\. pass' || true; } - @echo "======== Finished $(patsubst %-unopt,%,$@) (interpreted) ========" - -%-opt: tests/%-opt.o - @$(HC) -o tst $(HCFLAGS) $< $(TESTSUITE_OBJS) $(NDPLIB) - @echo "======== Testing $(patsubst %-opt,%,$@) (optimised) ========" - @./tst | tee $@ | { grep -v '\.\.\. pass' || true; } - @echo "======== Finished $(patsubst %-opt,%,$@) (optimised) ========" - @rm -f tst $< - diff --git a/examples/quickcheck/Testsuite.hs b/examples/quickcheck/Testsuite.hs deleted file mode 100644 --- a/examples/quickcheck/Testsuite.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Testsuite ( - module Testsuite.Preproc, - module Testsuite.Testcase, - module Testsuite.Utils, - - module Test.QuickCheck -) where - -import Testsuite.Preproc -import Testsuite.Testcase -import Testsuite.Utils - -import Test.QuickCheck - - diff --git a/examples/quickcheck/Testsuite/Preproc.hs b/examples/quickcheck/Testsuite/Preproc.hs deleted file mode 100644 --- a/examples/quickcheck/Testsuite/Preproc.hs +++ /dev/null @@ -1,104 +0,0 @@ -module Testsuite.Preproc ( testcases, (<@) ) -where - -import Language.Haskell.TH -import Data.List -import Data.Maybe (fromJust) -import Monad (liftM) - -data Prop = Prop { propName :: Name - , propTyvars :: [Name] - , propType :: Type - } - -data Inst = Inst { instName :: Name - , instSubsts :: [(Name, Type)] - , instExp :: Exp - } - -(<@) :: String -> Q Type -> Q (String, Type) -pfx <@ qty = liftM ((,) pfx) qty - -type Domain = [(String, [Type])] - -testcases :: [Q (String, Type)] -> Q [Dec] -> Q [Dec] -testcases qdom qdecs = - do - dom <- liftM domain $ sequence qdom - decs <- qdecs - let props = embed . generate dom $ properties decs - rn = AppE (VarE (mkName "runTests")) - props - main = ValD (VarP (mkName "main")) - (NormalB rn) [] - return (decs ++ [main]) - -domain :: [(String, Type)] -> Domain -domain ps = sortBy cmpPfx - . zip (map fst ps) - . map types - $ map snd ps - where - cmpPfx (s,_) (s',_) = length s' `compare` length s - -types :: Type -> [Type] -types ty = case unAppT ty of - (TupleT _ : tys) -> tys - _ -> [ty] - where - unAppT (AppT t u) = unAppT t ++ [u] - unAppT t = [t] - - -instid :: Inst -> String -instid inst = name inst ++ env inst - where - name (Inst { instName = nm }) = - let s = nameBase nm - in - if "prop_" `isPrefixOf` s then drop 5 s else s - - env (Inst { instSubsts = substs }) - | null substs = "" - | otherwise = let ss = [nameBase tv ++ " = " ++ pprint ty - | (tv, ty) <- substs] - in "[" ++ head ss ++ concatMap (", " ++) (tail ss) ++ "]" - -properties :: [Dec] -> [Prop] -properties decs = [mkProp nm ty | SigD nm ty <- decs] - where - mkProp nm (ForallT vars _ ty) = Prop nm vars ty - mkProp nm ty = Prop nm [] ty - -embed :: [Inst] -> Exp -embed insts = ListE [((VarE $ mkName "mkTest") `AppE` - (LitE . StringL $ instid i)) `AppE` - instExp i - | i <- insts ] - -generate :: Domain -> [Prop] -> [Inst] -generate dom = concatMap gen - where - gen prop@(Prop { propName = name - , propTyvars = [] - , propType = ty }) = - [Inst name [] (VarE name `SigE` ty)] - gen prop@(Prop { propName = name - , propTyvars = tvs - , propType = ty }) = - [Inst name env (VarE name `SigE` subst env ty) - | env <- combinations tvs dom] - -subst :: [(Name, Type)] -> Type -> Type -subst env (VarT nm) = case lookup nm env of - Just ty -> ty -subst env (AppT t u) = AppT (subst env t) (subst env u) -subst env t = t - -combinations :: [Name] -> [(String, [Type])] -> [[(Name, Type)]] -combinations [] _ = [[]] -combinations (n:ns) dom = [(n,t) : ps | t <- ts, ps <- combinations ns dom] - where - s = nameBase n - ts = snd . fromJust $ find ((`isPrefixOf` s) . fst) dom - diff --git a/examples/quickcheck/Testsuite/Testcase.hs b/examples/quickcheck/Testsuite/Testcase.hs deleted file mode 100644 --- a/examples/quickcheck/Testsuite/Testcase.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Testsuite.Testcase ( - Test(..), mkTest, runTests -) where - -import Test.QuickCheck -import Test.QuickCheck.Batch (TestResult(..), run, defOpt) - -import Text.Regex.Base - -import System.Environment (getArgs) - -import Data.Maybe (isJust) - -import IO - -data Test = Test { testName :: String - , testProperty :: Property - } - -mkTest :: Testable a => String -> a -> Test -mkTest name = Test name . property - -runTests :: [Test] -> IO () -runTests tests = - do - args <- getArgs - mapM_ chk $ pick args tests - where - chk (Test { testName = name, testProperty = prop }) = - do - putStr $ name ++ spaces (60 - length name) ++ "... " - hFlush stdout - res <- run prop defOpt - case res of - TestOk _ n _ -> putStrLn $ "pass (" ++ show n ++ ")" - TestExausted _ n _ -> putStrLn $ "EXHAUSTED (" ++ show n ++ ")" - TestFailed s n -> - do - putStrLn $ "FAIL (" ++ show n ++ ")" - mapM_ putStrLn $ map (" " ++) s - TestAborted e -> - do - putStrLn $ "ABORTED" - putStrLn $ " " ++ show e - hFlush stdout - spaces n | n <= 0 = "" - | otherwise = replicate n ' ' - -pick :: [String] -> [Test] -> [Test] -pick [] = id -pick ss = filter (match (map mkRegex ss)) - where - match :: [Regex] -> Test -> Bool - match rs tst = any (\r -> isJust . matchRegex r $ testName tst) rs - diff --git a/examples/quickcheck/Testsuite/Utils.hs b/examples/quickcheck/Testsuite/Utils.hs deleted file mode 100644 --- a/examples/quickcheck/Testsuite/Utils.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Testsuite.Utils ( - Len(..), EFL, - - gvector, gdist, gtype, vtype -) where - -import Test.QuickCheck -import Test.QuickCheck.Batch - -import Text.Show.Functions - -import Data.Array.Parallel.Base.Hyperstrict -import Data.Array.Parallel.Base.Fusion (EFL) -import Data.Array.Parallel.Unlifted -import Data.Array.Parallel.Distributed - -import Data.Char -import Monad (liftM) - --- infix 4 === - -newtype Len = Len Int deriving(Eq,Ord,Enum,Show,Num) - -instance Arbitrary Char where - arbitrary = fmap chr . sized $ \n -> choose (0,n) - coarbitrary = coarbitrary . ord - -instance (Arbitrary a, Arbitrary b) => Arbitrary (a :*: b) where - arbitrary = liftM (uncurry (:*:)) arbitrary - coarbitrary (a :*: b) = coarbitrary (a,b) - -instance Arbitrary Len where - arbitrary = sized $ \n -> Len `fmap` choose (0,n) - coarbitrary (Len n) = coarbitrary n - -instance Arbitrary a => Arbitrary (MaybeS a) where - arbitrary = frequency [(1, return NothingS), (3, liftM JustS arbitrary)] - coarbitrary NothingS = variant 0 - coarbitrary (JustS x) = variant 1 . coarbitrary x - -instance (UA a, Arbitrary a) => Arbitrary (UArr a) where - arbitrary = fmap toU arbitrary - coarbitrary = coarbitrary . fromU - -instance (UA a, Arbitrary a) => Arbitrary (SUArr a) where - arbitrary = fmap toSU arbitrary - coarbitrary = coarbitrary . fromSU - -instance Arbitrary Gang where - arbitrary = sized $ \n -> sequentialGang `fmap` choose (1,n+1) - coarbitrary = coarbitrary . gangSize - -gvector :: Arbitrary a => Gang -> Gen [a] -gvector = vector . gangSize - -gdist :: (Arbitrary a, DT a) => Gang -> Gen (Dist a) -gdist g = sized $ \n -> resize (n `div` gangSize g + 1) $ toD g `fmap` gvector g - -vtype :: Gen [a] -> a -> Gen [a] -vtype = const - -gtype :: Gen (Dist a) -> a -> Gen (Dist a) -gtype = const - -{- -class Eq a => SemEq a where - (===) :: a -> a -> Bool - -instance Eq a => SemEq a where - x === y | isBottom x = isBottom y - | isBottom y = False - | otherwise = x == y --} - diff --git a/examples/quickcheck/tests/BUArr.hs b/examples/quickcheck/tests/BUArr.hs deleted file mode 100644 --- a/examples/quickcheck/tests/BUArr.hs +++ /dev/null @@ -1,116 +0,0 @@ -import Testsuite - -import Data.Array.Parallel.Arr.BUArr -import Data.Array.Parallel.Base.Hyperstrict - -instance (UAE a, Arbitrary a) => Arbitrary (BUArr a) where - arbitrary = fmap toBU arbitrary - coarbitrary = coarbitrary . fromBU - -$(testcases [ "" <@ [t| ( (), Bool, Char, Int ) |] - , "acc" <@ [t| ( (), Int ) |] - , "num" <@ [t| ( Int ) |] - ] - [d| - -- if this doesn't work nothing else will, so run this first - prop_fromBU_toBU :: (Eq a, UAE a) => [a] -> Bool - prop_fromBU_toBU xs = fromBU (toBU xs) == xs - - -- Basic operations - -- ---------------- - - prop_lengthBU :: UAE a => BUArr a -> Bool - prop_lengthBU arr = lengthBU arr == length (fromBU arr) - - prop_emptyBU :: (Eq a, UAE a) => a -> Bool - prop_emptyBU x = fromBU emptyBU == tail [x] - - prop_unitsBU :: Len -> Bool - prop_unitsBU (Len n) = - fromBU (unitsBU n) == replicate n () - - prop_replicateBU :: (Eq a, UAE a) => Len -> a -> Bool - prop_replicateBU (Len n) x = - fromBU (replicateBU n x) == replicate n x - - prop_indexBU :: (Eq a, UAE a) => BUArr a -> Len -> Property - prop_indexBU arr (Len i) = - i < lengthBU arr - ==> (arr `indexBU` i) == (fromBU arr !! i) - - prop_sliceBU :: (Eq a, UAE a) => BUArr a -> Len -> Len -> Property - prop_sliceBU arr (Len i) (Len n) = - i <= lengthBU arr && n <= lengthBU arr - i - ==> fromBU (sliceBU arr i n) == take n (drop i $ fromBU arr) - - prop_extractBU :: (Eq a, UAE a) => BUArr a -> Len -> Len -> Property - prop_extractBU arr (Len i) (Len n) = - i <= lengthBU arr && n <= lengthBU arr - i - ==> fromBU (extractBU arr i n) == take n (drop i $ fromBU arr) - - -- Higher-order operations - -- ----------------------- - - prop_mapBU :: (Eq b, UAE a, UAE b) => (a -> b) -> BUArr a -> Bool - prop_mapBU f arr = - fromBU (mapBU f arr) == map f (fromBU arr) - - prop_foldlBU :: (Eq a, UAE b) => (a -> b -> a) -> a -> BUArr b -> Bool - prop_foldlBU f z arr = - foldlBU f z arr == foldl f z (fromBU arr) - - -- missing: foldBU - - - prop_scanlBU :: (Eq a, UAE a, UAE b) => (a -> b -> a) -> a -> BUArr b -> Bool - prop_scanlBU f z arr = - fromBU (scanlBU f z arr) == init (scanl f z (fromBU arr)) - - -- missing: scanBU - -- missing: loopBU - - -- Arithmetic operations - -- --------------------- - - prop_sumBU :: (Eq num, UAE num, Num num) => BUArr num -> Bool - prop_sumBU arr = - sumBU arr == sum (fromBU arr) - - -- Equality - -- -------- - - prop_eqBU_1 :: (Eq a, UAE a) => BUArr a -> Bool - prop_eqBU_1 arr = arr == arr - - prop_eqBU_2 :: (Eq a, UAE a) => BUArr a -> BUArr a -> Bool - prop_eqBU_2 arr brr = (arr == brr) == (fromBU arr == fromBU brr) - - -- Fusion - -- ------ - - prop_loopBU_replicateBU - :: (UAE e, Eq acc, Eq e', UAE e') - => EFL acc e e' -> acc -> Len -> e -> Bool - prop_loopBU_replicateBU mf start (Len n) v = - loopBU mf start (replicateBU n v) - == loopBU (\a _ -> mf a v) start (unitsBU n) - - {- FIXME: disabled - too many type variables - prop_fusion2 :: (Eq acc2, Eq e3, UAE e1, UAE e2, UAE e3) - => LoopFn acc1 e1 e2 - -> LoopFn acc2 e2 e3 - -> acc1 -> acc2 -> BUArr e1 -> Bool - prop_fusion2 mf1 mf2 start1 start2 arr = - loopBU mf2 start2 (loopArr (loopBU mf1 start1 arr)) == - let - mf (acc1 :*: acc2) e = - case mf1 acc1 e of - (acc1' :*: Nothing) -> ((acc1' :*: acc2) :*: Nothing) - (acc1' :*: Just e') -> - case mf2 acc2 e' of - (acc2' :*: res) -> ((acc1' :*: acc2') :*: res) - in - loopSndAcc (loopBU mf (start1 :*: start2) arr) - -} - |]) - diff --git a/examples/quickcheck/tests/Distributed.hs b/examples/quickcheck/tests/Distributed.hs deleted file mode 100644 --- a/examples/quickcheck/tests/Distributed.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# OPTIONS -fallow-undecidable-instances #-} - -import Testsuite - -import Data.Array.Parallel.Unlifted.Distributed -import Data.Array.Parallel.Unlifted -import Data.Array.Parallel.Base.Hyperstrict - -class (Eq a, DT a, Arbitrary a, Show a) => D a -instance (Eq a, DT a, Arbitrary a, Show a) => D a - -class (Eq a, UA a, Arbitrary a, Show a) => U a -instance (Eq a, UA a, Arbitrary a, Show a) => U a - -$(testcases [ "" <@ [t| ( (), Bool, Char, Int, UArr (), UArr Int ) |] - , "sc" <@ [t| ( (), Bool, Char, Int ) |] - , "acc" <@ [t| ( (), Int ) |] - , "num" <@ [t| ( Int ) |] - , "pq" <@ [t| ( (), Int ) |] - ] - [d| - -- if this doesn't work nothing else will, so run this first - prop_fromD_toD :: D a => Gang -> a -> Property - prop_fromD_toD g a = - forAll (gvector g `vtype` a) $ \xs -> - fromD g (toD g xs) == xs - - -- Equality - -- -------- - - prop_eqD_1 :: D a => Gang -> a -> Property - prop_eqD_1 g a = - forAll (gdist g `gtype` a) $ \d -> - eqD g d d - - prop_eqD_2 :: D a => Gang -> a -> Property - prop_eqD_2 g a = - forAll (gdist g `gtype` a) $ \dx -> - forAll (gdist g `gtype` a) $ \dy -> - eqD g dx dy == (fromD g dx == fromD g dy) - - prop_neqD_1 :: D a => Gang -> a -> Property - prop_neqD_1 g a = - forAll (gdist g `gtype` a) $ \d -> - not (neqD g d d) - - prop_neqD_eqD :: D a => Gang -> a -> Property - prop_neqD_eqD g a = - forAll (gdist g `gtype` a) $ \dx -> - forAll (gdist g `gtype` a) $ \dy -> - eqD g dx dy == not (neqD g dx dy) - - -- Higher-order combinators - -- ------------------------ - - prop_mapD :: (D a, D b) => Gang -> (a -> b) -> Property - prop_mapD g f = - forAll (gdist g) $ \d -> - fromD g (mapD g f d) == map f (fromD g d) - - prop_zipWithD :: (D a, D b, D c) => Gang -> (a -> b -> c) -> Property - prop_zipWithD g f = - forAll (gdist g) $ \dx -> - forAll (gdist g) $ \dy -> - fromD g (zipWithD g f dx dy) == zipWith f (fromD g dx) (fromD g dy) - - prop_foldD :: D a => Gang -> (a -> a -> a) -> Property - prop_foldD g f = - forAll (gdist g) $ \d -> - foldD g f d == foldl1 f (fromD g d) - - prop_scanD :: D a => Gang -> (a -> a -> a) -> a -> Property - prop_scanD g f z = - forAll (gdist g) $ \d -> - let (d' :*: r) = scanD g f z d - in fromD g d' ++ [r] == scanl f z (fromD g d) - - -- Distributed scalars - -- ------------------- - - prop_scalarD :: D sc => Gang -> sc -> Bool - prop_scalarD g x = - fromD g (scalarD g x) == replicate (gangSize g) x - - prop_andD :: Gang -> Property - prop_andD g = - forAll (gdist g) $ \d -> - andD g d == and (fromD g d) - - prop_orD :: Gang -> Property - prop_orD g = - forAll (gdist g) $ \d -> - orD g d == or (fromD g d) - - prop_sumD :: (D num, Num num) => Gang -> num -> Property - prop_sumD g num = - forAll (gdist g `gtype` num) $ \d -> - sumD g d == sum (fromD g d) - - -- Distributed pairs - -- ----------------- - - prop_zipD :: (D pq1, D pq2) => Gang -> pq1 -> pq2 -> Property - prop_zipD g pq1 pq2 = - forAll (gdist g `gtype` pq1) $ \dx -> - forAll (gdist g `gtype` pq2) $ \dy -> - fromD g (zipD dx dy) == zipWith (:*:) (fromD g dx) (fromD g dy) - - prop_unzipD :: (D pq1, D pq2) => Gang -> pq1 -> pq2 -> Property - prop_unzipD g pq1 pq2 = - forAll (gdist g `gtype` (pq1 :*: pq2)) $ \d -> - let (dx :*: dy) = unzipD d - in - (fromD g dx, fromD g dy) == unzip (map unpairS (fromD g d)) - - prop_fstD :: (D pq1, D pq2) => Gang -> pq1 -> pq2 -> Property - prop_fstD g pq1 pq2 = - forAll (gdist g `gtype` (pq1 :*: pq2)) $ \d -> - fromD g (fstD d) == map fstS (fromD g d) - - prop_sndD :: (D pq1, D pq2) => Gang -> pq1 -> pq2 -> Property - prop_sndD g pq1 pq2 = - forAll (gdist g `gtype` (pq1 :*: pq2)) $ \d -> - fromD g (sndD d) == map sndS (fromD g d) - - -- Distributed arrays - -- ------------------ - - prop_splitLengthD_1 :: U sc => Gang -> UArr sc -> Bool - prop_splitLengthD_1 g arr = - sumD g (splitLengthD g arr) == lengthU arr - - -- check that the distribution is [k+1,k+1,k+1,...,k,k,k,...] - prop_splitLengthD_2 :: U sc => Gang -> UArr sc -> Bool - prop_splitLengthD_2 g arr = - chk (fromD g (splitLengthD g arr)) - where - chk (l:ls) = let ns = dropWhile (==l) ls - in - null ns - || (all (== head ns) ns - && head ns == l - 1) - - prop_lengthD :: U sc => Gang -> sc -> Property - prop_lengthD g x = - forAll (gdist g `gtype` replicateU 0 x) $ \darr -> - eqD g (lengthD darr) (mapD g lengthU darr) - - prop_splitD :: (UA sc, Eq sc) => Gang -> UArr sc -> Bool - prop_splitD g arr = - foldr1 (+:+) (fromD g (splitD g arr)) == arr - - prop_joinD :: U sc => Gang -> sc -> Property - prop_joinD g x = - forAll (gdist g `gtype` replicateU 0 x) $ \darr -> - joinD g darr == foldr1 (+:+) (fromD g darr) - - prop_joinD_splitD :: (UA sc, Eq sc) => Gang -> UArr sc -> Bool - prop_joinD_splitD g arr = - joinD g (splitD g arr) == arr - - |]) - diff --git a/examples/quickcheck/tests/UnliftedSU.hs b/examples/quickcheck/tests/UnliftedSU.hs deleted file mode 100644 --- a/examples/quickcheck/tests/UnliftedSU.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# OPTIONS -fallow-undecidable-instances #-} - -import Testsuite - -import Data.Array.Parallel.Unlifted - -class (Eq a, UA a) => U a -instance (Eq a, UA a) => U a - - - -$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] - , "acc" <@ [t| ( (), Int ) |] - , "num" <@ [t| ( Int ) |] - , "ord" <@ [t| ( (), Char, Bool, Int ) |] - , "enum" <@ [t| ( (), Char, Bool, Int ) |] - ] - [d| - -- if this doesn't work nothing else will, so run this first - prop_fromSU_toSU :: U a => [[a]] -> Bool - prop_fromSU_toSU xss = fromSU (toSU xss) == xss - - prop_concatSU :: U a => SUArr a -> SUArr a -> Bool - prop_concatSU xss yss = - (concatSU xss == concatSU yss) - == (concat (fromSU xss) == concat (fromSU yss)) - - prop_flattenSU :: U a => SUArr a -> SUArr a -> Bool - prop_flattenSU xss yss = - (xss == yss) == (flattenSU xss == flattenSU yss) - - -- missing: (>:) - -- missing: segmentU - - prop_replicateSU :: U a => UArr (Int :*: a) -> Bool - prop_replicateSU ps = let (ms :*: xs) = unzipU ps - ns = mapU abs ms - in - fromSU (replicateSU ns xs) == zipWith replicate (fromU ns) (fromU xs) - - prop_foldlSU :: (U a, U b) => (a -> b -> a) -> a -> SUArr b -> Bool - prop_foldlSU f z xss = - fromU (foldlSU f z xss) == map (foldl f z) (fromSU xss) - - -- missing: foldSU - -- missing: loopSU - - prop_andSU :: SUArr Bool -> Bool - prop_andSU bss = - fromU (andSU bss) == map and (fromSU bss) - - prop_orSU :: SUArr Bool -> Bool - prop_orSU bss = - fromU (orSU bss) == map or (fromSU bss) - - prop_sumSU :: (U num, Num num) => SUArr num -> Bool - prop_sumSU nss = - fromU (sumSU nss) == map sum (fromSU nss) - - prop_productSU :: (U num, Num num) => SUArr num -> Bool - prop_productSU nss = - fromU (productSU nss) == map product (fromSU nss) - - -- missing: maximumSU - -- missing: minimumSU - - -- missing: enumFromToSU - -- missing: enumFromThenToSU - - -- missing: fusion rules - |]) - diff --git a/examples/quickcheck/tests/Unlifted_Basics.hs b/examples/quickcheck/tests/Unlifted_Basics.hs deleted file mode 100644 --- a/examples/quickcheck/tests/Unlifted_Basics.hs +++ /dev/null @@ -1,51 +0,0 @@ -import Testsuite - -import Data.Array.Parallel.Unlifted - -$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] - , "acc" <@ [t| ( (), Int ) |] - , "num" <@ [t| ( Int ) |] - , "ord" <@ [t| ( (), Char, Bool, Int ) |] - , "enum" <@ [t| ( (), Char, Bool, Int ) |] - ] - [d| - -- if this doesn't work nothing else will, so run this first - prop_fromU_toU :: (Eq a, UA a) => [a] -> Bool - prop_fromU_toU xs = fromU (toU xs) == xs - - prop_lengthU :: UA a => UArr a -> Bool - prop_lengthU arr = lengthU arr == length (fromU arr) - - prop_nullU :: UA a => UArr a -> Bool - prop_nullU arr = nullU arr == (lengthU arr == 0) - - prop_emptyU :: (Eq a, UA a) => a -> Bool - prop_emptyU x = fromU emptyU == tail [x] - - prop_unitsU :: Len -> Bool - prop_unitsU (Len n) = - fromU (unitsU n) == replicate n () - - prop_replicateU :: (Eq a, UA a) => Len -> a -> Bool - prop_replicateU (Len n) x = - fromU (replicateU n x) == replicate n x - - prop_indexU :: (Eq a, UA a) => UArr a -> Len -> Property - prop_indexU arr (Len i) = - i < lengthU arr - ==> (arr !: i) == (fromU arr !! i) - - prop_appendU :: (Eq a, UA a) => UArr a -> UArr a -> Bool - prop_appendU arr brr = - fromU (arr +:+ brr) == fromU arr ++ fromU brr - - -- Equality - -- -------- - - prop_eqU_1 :: (Eq a, UA a) => UArr a -> Bool - prop_eqU_1 arr = arr == arr - - prop_eqU_2 :: (Eq a, UA a) => UArr a -> UArr a -> Bool - prop_eqU_2 arr brr = (arr == brr) == (fromU arr == fromU brr) - |]) - diff --git a/examples/quickcheck/tests/Unlifted_Combinators.hs b/examples/quickcheck/tests/Unlifted_Combinators.hs deleted file mode 100644 --- a/examples/quickcheck/tests/Unlifted_Combinators.hs +++ /dev/null @@ -1,48 +0,0 @@ -import Testsuite - -import Data.Array.Parallel.Unlifted - -$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] - , "acc" <@ [t| ( (), Int ) |] - , "num" <@ [t| ( Int ) |] - , "ord" <@ [t| ( (), Char, Bool, Int ) |] - , "enum" <@ [t| ( (), Char, Bool, Int ) |] - ] - [d| - prop_mapU :: (UA a, Eq b, UA b) => (a -> b) -> UArr a -> Bool - prop_mapU f arr = - fromU (mapU f arr) == map f (fromU arr) - - -- missing: zipWithU - -- missing: zipWith3U - - prop_filterU :: (Eq a, UA a) => (a -> Bool) -> UArr a -> Bool - prop_filterU f arr = - fromU (filterU f arr) == filter f (fromU arr) - - prop_foldlU :: (UA a, Eq b) => (b -> a -> b) -> b -> UArr a -> Bool - prop_foldlU f z arr = - foldlU f z arr == foldl f z (fromU arr) - - prop_foldl1U :: (UA a, Eq a) => (a -> a -> a) -> UArr a -> Property - prop_foldl1U f arr = - not (nullU arr) - ==> foldl1U f arr == foldl1 f (fromU arr) - - -- missing: foldU - -- missing: fold1U - - prop_scanlU :: (UA a, UA b, Eq b) => (b -> a -> b) -> b -> UArr a -> Bool - prop_scanlU f z arr = - fromU (scanlU f z arr) == init (scanl f z (fromU arr)) - - prop_scanl1U :: (UA a, Eq a) => (a -> a -> a) -> UArr a -> Property - prop_scanl1U f arr = - not (nullU arr) - ==> fromU (scanl1U f arr) == init (scanl1 f (fromU arr)) - - -- missing: scanU - -- missing: scan1U - -- missing: loopU - |]) - diff --git a/examples/quickcheck/tests/Unlifted_Fusion.hs b/examples/quickcheck/tests/Unlifted_Fusion.hs deleted file mode 100644 --- a/examples/quickcheck/tests/Unlifted_Fusion.hs +++ /dev/null @@ -1,38 +0,0 @@ -import Testsuite - -import Data.Array.Parallel.Unlifted - -$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] - , "acc" <@ [t| ( (), Int ) |] - , "num" <@ [t| ( Int ) |] - , "ord" <@ [t| ( (), Char, Bool, Int ) |] - , "enum" <@ [t| ( (), Char, Bool, Int ) |] - ] - [d| - prop_loopU_replicateU :: (UA e, Eq acc, Eq e', UA e') - => EFL acc e e' -> acc -> Len -> e -> Bool - prop_loopU_replicateU em start (Len n) v = - loopU em start (replicateU n v) == - loopU (\a _ -> em a v) start (unitsU n) - - {- FIXME: disabled - too many type variables - prop_fusion2 :: (Eq acc1, Eq acc2, Eq e1, Eq e2, Eq e3, - UA e1, UA e2, UA e3) - => LoopFn acc1 e1 e2 -> LoopFn acc2 e2 e3 - -> acc1 -> acc2 -> UArr e1 -> Bool - prop_fusion2 em1 em2 start1 start2 arr = - loopU em2 start2 (loopArr (loopU em1 start1 arr)) == - let - em (acc1 :*: acc2) e = - case em1 acc1 e of - (acc1' :*: Nothing) -> ((acc1' :*: acc2) :*: Nothing) - (acc1' :*: Just e') -> - case em2 acc2 e' of - (acc2' :*: res) -> ((acc1' :*: acc2') :*: res) - in - loopSndAcc (loopU em (start1 :*: start2) arr) - -} - - -- missing: segmented operations - |]) - diff --git a/examples/quickcheck/tests/Unlifted_Permutes.hs b/examples/quickcheck/tests/Unlifted_Permutes.hs deleted file mode 100644 --- a/examples/quickcheck/tests/Unlifted_Permutes.hs +++ /dev/null @@ -1,20 +0,0 @@ -import Testsuite - -import Data.Array.Parallel.Unlifted - -$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] - , "acc" <@ [t| ( (), Int ) |] - , "num" <@ [t| ( Int ) |] - , "ord" <@ [t| ( (), Char, Bool, Int ) |] - , "enum" <@ [t| ( (), Char, Bool, Int ) |] - ] - [d| - -- missing: permuteU - -- missing: bpermuteU - -- missing: bpermuteDftU - - prop_reverseU :: (Eq a, UA a) => UArr a -> Bool - prop_reverseU arr = - fromU (reverseU arr) == reverse (fromU arr) - |]) - diff --git a/examples/quickcheck/tests/Unlifted_Subarrays.hs b/examples/quickcheck/tests/Unlifted_Subarrays.hs deleted file mode 100644 --- a/examples/quickcheck/tests/Unlifted_Subarrays.hs +++ /dev/null @@ -1,38 +0,0 @@ -import Testsuite - -import Data.Array.Parallel.Unlifted - -$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] - , "acc" <@ [t| ( (), Int ) |] - , "num" <@ [t| ( Int ) |] - , "ord" <@ [t| ( (), Char, Bool, Int ) |] - , "enum" <@ [t| ( (), Char, Bool, Int ) |] - ] - [d| - prop_sliceU :: (Eq a, UA a) => UArr a -> Len -> Len -> Property - prop_sliceU arr (Len i) (Len n) = - i <= lengthU arr && n <= lengthU arr - i - ==> fromU (sliceU arr i n) == take n (drop i $ fromU arr) - - prop_extractU :: (Eq a, UA a) => UArr a -> Len -> Len -> Property - prop_extractU arr (Len i) (Len n) = - i <= lengthU arr && n <= lengthU arr - i - ==> fromU (extractU arr i n) == take n (drop i $ fromU arr) - - prop_takeU :: (Eq a, UA a) => Len -> UArr a -> Property - prop_takeU (Len n) arr = - n <= lengthU arr - ==> fromU (takeU n arr) == take n (fromU arr) - - prop_dropU :: (Eq a, UA a) => Len -> UArr a -> Property - prop_dropU (Len n) arr = - n <= lengthU arr - ==> fromU (dropU n arr) == drop n (fromU arr) - - prop_splitAtU :: (Eq a, UA a) => Len -> UArr a -> Property - prop_splitAtU (Len n) arr = - n <= lengthU arr - ==> let (brr, crr) = splitAtU n arr - in (fromU brr, fromU crr) == splitAt n (fromU arr) - |]) - diff --git a/examples/quickcheck/tests/Unlifted_Sums.hs b/examples/quickcheck/tests/Unlifted_Sums.hs deleted file mode 100644 --- a/examples/quickcheck/tests/Unlifted_Sums.hs +++ /dev/null @@ -1,62 +0,0 @@ -import Testsuite - -import Data.Array.Parallel.Unlifted - -$(testcases [ "" <@ [t| ( (), Char, Bool, Int ) |] - , "acc" <@ [t| ( (), Int ) |] - , "num" <@ [t| ( Int ) |] - , "ord" <@ [t| ( (), Char, Bool, Int ) |] - , "enum" <@ [t| ( (), Char, Bool, Int ) |] - ] - [d| - -- Searching - -- --------- - prop_elemU :: (Eq e, UA e) => e -> UArr e -> Bool - prop_elemU x arr = - elemU x arr == elem x (fromU arr) - - prop_notElemU :: (Eq e, UA e) => e -> UArr e -> Bool - prop_notElemU x arr = - notElemU x arr == notElem x (fromU arr) - - -- Logic operations - -- ---------------- - - prop_andU :: UArr Bool -> Bool - prop_andU arr = - andU arr == and (fromU arr) - - prop_orU :: UArr Bool -> Bool - prop_orU arr = - orU arr == or (fromU arr) - - prop_anyU :: UA e => (e -> Bool) -> UArr e -> Bool - prop_anyU f arr = - anyU f arr == any f (fromU arr) - - prop_allU :: UA e => (e -> Bool) -> UArr e -> Bool - prop_allU f arr = - allU f arr == all f (fromU arr) - - -- Arithmetic operations - -- --------------------- - - prop_sumU :: (Eq num, UA num, Num num) => UArr num -> Bool - prop_sumU arr = - sumU arr == sum (fromU arr) - - prop_productU :: (Eq num, UA num, Num num) => UArr num -> Bool - prop_productU arr = - productU arr == product (fromU arr) - - prop_maximumU :: (Ord ord, UA ord) => UArr ord -> Property - prop_maximumU arr = - not (nullU arr) - ==> maximumU arr == maximum (fromU arr) - - prop_minimumU :: (Ord ord, UA ord) => UArr ord -> Property - prop_minimumU arr = - not (nullU arr) - ==> minimumU arr == minimum (fromU arr) - |]) - diff --git a/examples/quickhull/Makefile b/examples/quickhull/Makefile deleted file mode 100644 --- a/examples/quickhull/Makefile +++ /dev/null @@ -1,10 +0,0 @@ -TESTDIR = .. -PROGS = quickhull -HCCFLAGS = -optc-O3 -include $(TESTDIR)/mk/test.mk - -quickhull.o: Types.hi QH.hi -QH.o: Types.hi - -quickhull: quickhull.o QH.o Types.o - diff --git a/examples/quickhull/QH.hs b/examples/quickhull/QH.hs deleted file mode 100644 --- a/examples/quickhull/QH.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE PArr #-} -{-# OPTIONS -fvectorise #-} - -module QH (quickHull) where - -import Types - -import Data.Array.Parallel.Prelude -import Data.Array.Parallel.Prelude.Double -import qualified Data.Array.Parallel.Prelude.Int as Int - -import qualified Prelude - -distance :: Point -> Line -> Double -distance (Point xo yo) (Line (Point x1 y1) (Point x2 y2)) - = (x1-xo) * (y2 - yo) - (y1 - yo) * (x2 - xo) - -hsplit points line@(Line p1 p2) - | lengthP packed Int.< 2 = singletonP p1 +:+ packed - | otherwise - = concatP [: hsplit packed ends - | ends <- singletonP (Line p1 pm) +:+ singletonP (Line pm p2) :] - where - cross = [: distance p line | p <- points :] - packed = [: p | (p,c) <- zipP points cross, c > 0.0 :] - - pm = points !: maxIndexP cross - -quickHull' points - = concatP [: hsplit points ends - | ends <- singletonP (Line minx maxx) - +:+ singletonP (Line maxx minx) :] - where - xs = [: x | Point x y <- points :] - minx = points !: minIndexP xs - maxx = points !: maxIndexP xs - -quickHull :: PArray Point -> PArray Point -quickHull ps = toPArrayP (quickHull' (fromPArrayP ps)) - diff --git a/examples/quickhull/Types.hs b/examples/quickhull/Types.hs deleted file mode 100644 --- a/examples/quickhull/Types.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE PArr #-} -{-# OPTIONS -fvectorise #-} - -module Types ( Point(..), Line(..), points, xsOf, ysOf) where - -import Data.Array.Parallel.Prelude - -data Point = Point Double Double -data Line = Line Point Point - -points' :: [:Double:] -> [:Double:] -> [:Point:] -points' xs ys = zipWithP Point xs ys - -points :: PArray Double -> PArray Double -> PArray Point -points xs ys = toPArrayP (points' (fromPArrayP xs) (fromPArrayP ys)) - -xsOf' :: [:Point:] -> [:Double:] -xsOf' ps = [: x | Point x _ <- ps :] - -xsOf :: PArray Point -> PArray Double -xsOf ps = toPArrayP (xsOf' (fromPArrayP ps)) - -ysOf' :: [:Point:] -> [:Double:] -ysOf' ps = [: y | Point _ y <- ps :] - -ysOf :: PArray Point -> PArray Double -ysOf ps = toPArrayP (ysOf' (fromPArrayP ps)) - - diff --git a/examples/quickhull/quickhull.hs b/examples/quickhull/quickhull.hs deleted file mode 100644 --- a/examples/quickhull/quickhull.hs +++ /dev/null @@ -1,18 +0,0 @@ -import Types -import QH - -import Data.Array.Parallel.Lifted -import Data.Array.Parallel.Unlifted - -pts = points (fromUArrPA' (toU (map fst coords))) - (fromUArrPA' (toU (map snd coords))) - where - coords = [(3,3),(2,7),(0,0),(8,5), (4,6),(5,3),(9,6),(10,0)] - -result = zip (fromU (toUArrPA (xsOf ps))) - (fromU (toUArrPA (ysOf ps))) - where - ps = quickHull pts - -main = print result - diff --git a/examples/ref/DotProd.hs b/examples/ref/DotProd.hs deleted file mode 100644 --- a/examples/ref/DotProd.hs +++ /dev/null @@ -1,254 +0,0 @@ --- Simple computation of the dot product in Haskell (using various array --- implementations) --- --- Compile and run with --- --- ghc -ffi -O2 -fliberate-case-threshold100 -o dotprod DotProd.hs dotprod.o\ --- && ./dotprod +RTS -K10M - --- standard libraries -import CPUTime -import Random - --- FFI -import Foreign -import Foreign.C - --- GHC libraries -import Data.Array -import Data.Array.Unboxed (UArray) -import qualified - Data.Array.Unboxed as U -import Control.Exception (evaluate) -import System.Mem (performGC) - - --- arrays types --- -type Vector = Array Int Float -type UVector = UArray Int Float -type CVector = Ptr Float - --- generates a random vector of the given length in NF --- -generateVector :: Int -> IO Vector -generateVector n = - do - rg <- newStdGen - let fs = take n $ randomRs (-100, 100) rg - arr = listArray (0, n - 1) fs - evaluate $ sum (elems arr) -- make sure it is brought in NF - return arr - --- convert a vector into an UVector in NF --- -vectorToUVector :: Vector -> IO UVector -vectorToUVector v = - do - let uv = U.listArray (bounds v) . elems $ v - evaluate $ sum (U.elems uv) - return uv - --- convert a vector into a CVector in NF --- -vectorToCVector :: Vector -> IO CVector -vectorToCVector v = newArray (elems v) - --- compute the dot product --- - --- vanilla -vectorDP1a :: Vector -> Vector -> IO Float -{-# NOINLINE vectorDP1a #-} -vectorDP1a v1 v2 = do - let r = sum [x * y | x <- elems v1 | y <- elems v2] - evaluate r - --- vanilla -vectorDP1b :: Vector -> Vector -> IO Float -{-# NOINLINE vectorDP1b #-} -vectorDP1b v1 v2 = do - let r = sum [v1!i * v2!i | i <- indices v1] - evaluate r - --- array combinators -vectorDP2 :: Vector -> Vector -> IO Float -{-# NOINLINE vectorDP2 #-} -vectorDP2 v1 v2 = do - let r = sumA (zipWithA (*) v1 v2) - evaluate r - where - zipWithA f v1 v2 = listArray (0, n1) (loop 0) - where - n1 = snd (U.bounds v1) - loop i | i > n1 = [] - | otherwise = f (v1!i) (v2!i) : loop (i + 1) - -- - sumA v = loop 0 - where - n1 = snd (U.bounds v) - loop i | i > n1 = 0 - | otherwise = v!i + loop (i + 1) - --- explicit loop -vectorDP3 :: Vector -> Vector -> IO Float -{-# NOINLINE vectorDP3 #-} -vectorDP3 v1 v2 = - do - let n1 = snd (U.bounds v1) - r = loop 0 - where - loop i | i > n1 = 0 - | otherwise = v1!i * v2!i + loop (i + 1) - evaluate r - --- explicit loop w/ acc -vectorDP4 :: Vector -> Vector -> IO Float -{-# NOINLINE vectorDP4 #-} -vectorDP4 v1 v2 = - do - let n1 = snd (U.bounds v1) - r = loop 0 0 - where - loop i a | i > n1 = a - | otherwise = loop (i + 1) (v1!i * v2!i + a) - evaluate r - --- vanilla -uvectorDP1a :: UVector -> UVector -> IO Float -{-# NOINLINE uvectorDP1a #-} -uvectorDP1a v1 v2 = do - let r = sum $ zipWith (*) (U.elems v1) (U.elems v2) - evaluate r - --- vanilla -uvectorDP1b :: UVector -> UVector -> IO Float -{-# NOINLINE uvectorDP1b #-} -uvectorDP1b v1 v2 = do - let r = sum [v1 U.!i * v2 U.!i | i <- U.indices v1] - evaluate r - --- array combinators -uvectorDP2 :: UVector -> UVector -> IO Float -{-# NOINLINE uvectorDP2 #-} -uvectorDP2 v1 v2 = do - let r = sumA (zipWithA (*) v1 v2) - evaluate r - where - zipWithA :: (Float -> Float -> Float) -> UVector -> UVector -> UVector - zipWithA f v1 v2 = U.listArray (0, n1) (loop 0) - where - n1 = snd (U.bounds v1) - loop i | i > n1 = [] - | otherwise = f (v1 U.!i) (v2 U.!i) : loop (i + 1) - -- - sumA v = loop 0 - where - n1 = snd (U.bounds v) - loop i | i > n1 = 0 - | otherwise = v U.!i + loop (i + 1) - --- explicit loop -uvectorDP3 :: UVector -> UVector -> IO Float -{-# NOINLINE uvectorDP3 #-} -uvectorDP3 v1 v2 = - do - let n1 = snd (U.bounds v1) - r = loop 0 - where - loop i | i > n1 = 0 - | otherwise = v1 U.!i * v2 U.!i + loop (i + 1) - evaluate r - -- NB: main difference in Core to vectorDP3 is that here the compiler - -- decided to first go into the recursion and then do the indexing of v1 - -- and v2, whereas in vectorDP3 it's the other way around - --- explicit loop w/ acc -uvectorDP4 :: UVector -> UVector -> IO Float -{-# NOINLINE uvectorDP4 #-} -uvectorDP4 v1 v2 = - do - let n1 = snd (U.bounds v1) - r = loop 0 0 - where - loop i a | i > n1 = a - | otherwise = loop (i + 1) (v1 U.!i * v2 U.!i + a) - evaluate r - -- NB: this generates perfect code - --- merciless C code -foreign import ccall "dotprod.h" - cvectorDP :: CVector -> CVector -> Int -> IO Float - --- execute a function and print the result and execution time --- -execAndTime :: String -- description - -> IO Float -- benchmarked computation - -> IO () -execAndTime desc comp = - do - putStrLn $ "\n*** " ++ desc - performGC - start <- getCPUTime - result <- comp - end <- getCPUTime - let duration = (end - start) `div` 1000000000 - putStrLn $ "Result : " ++ show result - putStrLn $ "Running time: " ++ show duration ++ "ms" - -main :: IO () -main = do - putStrLn "Dot product benchmark" - putStrLn "=====================" - putStrLn $ "[time resolution: " ++ show (cpuTimePrecision `div` 1000000000)++ - "ms]" - -- - v1 <- generateVector 10000 - v2 <- generateVector 10000 - execAndTime "H98 arrays (ind'd compr) [n = 10000]" (vectorDP1b v1 v2) - -- - v1 <- generateVector 20000 - v2 <- generateVector 20000 - execAndTime "H98 arrays (ind'd compr) [n = 20000]" (vectorDP1b v1 v2) - -- - v1 <- generateVector 50000 - v2 <- generateVector 50000 - execAndTime "H98 arrays (par compr) [n = 50000]" (vectorDP1a v1 v2) - execAndTime "H98 arrays (ind'd compr) [n = 50000]" (vectorDP1b v1 v2) - execAndTime "H98 arrays (combinator-based) [n = 50000]" (vectorDP2 v1 v2) - execAndTime "H98 arrays (explicit loop) [n = 50000]" (vectorDP3 v1 v2) - execAndTime "H98 arrays (explicit loop w/ acc) [n = 50000]" (vectorDP4 v1 v2) - uv1 <- vectorToUVector v1 - uv2 <- vectorToUVector v2 - execAndTime "UArray (par compr) [n = 50000]" (uvectorDP1a uv1 uv2) - execAndTime "UArray (ind'd compr) [n = 50000]" (uvectorDP1b uv1 uv2) - execAndTime "UArray (combinator-based) [n = 50000]" (uvectorDP2 uv1 uv2) - execAndTime "UArray (explicit loop) [n = 50000]" (uvectorDP3 uv1 uv2) - execAndTime "UArray (explicit loop w/ acc) [n = 50000]" (uvectorDP4 uv1 uv2) - -- - v1 <- generateVector 100000 - v2 <- generateVector 100000 - execAndTime "H98 arrays (par compr) [n = 100000]" (vectorDP1a v1 v2) - execAndTime "H98 arrays (ind'd compr) [n = 100000]" (vectorDP1b v1 v2) - execAndTime "H98 arrays (combinator-based) [n = 100000]" (vectorDP2 v1 v2) - execAndTime "H98 arrays (explicit loop) [n = 100000]" (vectorDP3 v1 v2) - execAndTime "H98 arrays (explicit loop w/ acc) [n = 100000]"(vectorDP4 v1 v2) - uv1 <- vectorToUVector v1 - uv2 <- vectorToUVector v2 - execAndTime "UArray (par compr) [n = 100000]" (uvectorDP1a uv1 uv2) - execAndTime "UArray (ind'd compr) [n = 100000]" (uvectorDP1b uv1 uv2) - execAndTime "UArray (combinator-based) [n = 100000]" (uvectorDP2 uv1 uv2) - execAndTime "UArray (explicit loop) [n = 100000]" (uvectorDP3 uv1 uv2) - execAndTime "UArray (explicit loop w/ acc) [n = 100000]" (uvectorDP4 uv1 uv2) - cv1 <- vectorToCVector v1 - cv2 <- vectorToCVector v2 - execAndTime "C [n = 100000]" (cvectorDP cv1 cv2 100000) - -- - v1 <- generateVector 500000 - v2 <- generateVector 500000 - uv1 <- vectorToUVector v1 - uv2 <- vectorToUVector v2 - execAndTime "UArray (explicit loop w/ acc) [n = 500000]" (uvectorDP4 uv1 uv2) - cv1 <- vectorToCVector v1 - cv2 <- vectorToCVector v2 - execAndTime "C [n = 500000]" (cvectorDP cv1 cv2 500000) diff --git a/examples/ref/MatVecMul.hs b/examples/ref/MatVecMul.hs deleted file mode 100644 --- a/examples/ref/MatVecMul.hs +++ /dev/null @@ -1,303 +0,0 @@ --- Matrix vector multiplication in Haskell (using various array --- implementations) --- --- NB: To be precise, we measure the computation of the vector sum of the --- result vector of the matrix vector multiplication. --- --- Compile and run with --- --- ghc -ffi -O2 -fliberate-case-threshold100 -o matvecmul MatVecMul.hs\ --- matvecmul.o && ./matvecmul +RTS -K30M - --- standard libraries -import CPUTime -import Monad -import Random - --- FFI -import Foreign -import Foreign.C - --- GHC libraries -import Data.Array -import Data.Array.IArray (IArray) -import Data.Array.Unboxed (UArray) -import qualified - Data.Array.Unboxed as U -import Data.Array.MArray (newArray_, unsafeFreeze, writeArray) -import Data.Array.ST (STUArray) -import Control.Monad.ST (ST, runST) -import Control.Exception (evaluate) -import System.Mem (performGC) - -import Data.Array.Base (unsafeAt) -import GHC.Arr (unsafeIndex) - - --- arrays types --- -type Vector = Array Int Float -type Matrix = Array (Int, Int) Float -type UVector = UArray Int Float -type UMatrix = UArray (Int, Int) Float -type CVector = Ptr Float -type CMatrix = Ptr Float - - --- generates a random vector of the given length in NF --- -generateVector :: Int -> IO Vector -generateVector n = - do - rg <- newStdGen - let fs = take n $ randomRs (-100, 100) rg - arr = listArray (0, n - 1) fs - evaluate $ sum (elems arr) -- make sure it is brought in NF - return arr - --- generates a random square matrix in NF --- -generateMatrix :: Int -> IO Matrix -generateMatrix n = - do - rg <- newStdGen - let fs = take (n * n) $ randomRs (-100, 100) rg - arr = listArray ((0, 0), (n - 1, n - 1)) fs - evaluate $ sum (elems arr) -- make sure it is brought in NF - return arr - --- convert a standard Haskell array into an unboxed array in NF --- -arrayToIArray :: (Ix i, IArray arr e, Num e) => Array i e -> IO (arr i e) -arrayToIArray a = - do - let ia = U.listArray (bounds a) . elems $ a - evaluate $ sum (U.elems ia) - return ia - --- convert a vector into a CVector in NF --- -arrayToCArray :: (Ix i, Storable e) => Array i e -> IO (Ptr e) -arrayToCArray a = newArray (elems a) - --- compute the dot product --- - --- vanilla -mvm1 :: Matrix -> Vector -> IO (Vector, Float) -{-# NOINLINE mvm1 #-} -mvm1 a v = do - let (n, m) = snd (bounds a) - r = listArray (0, n) - [sum [a!(i,j) * v!j| j <- [0..m]] - | i <- [0..n]] - s <- evaluate $ sum (elems r) - return (r, s) -- returning both guarantees that the sum can't be - -- fused into the main computations - --- explicit inner loop -mvm3 :: Matrix -> Vector -> IO (Vector, Float) -{-# NOINLINE mvm3 #-} -mvm3 a v = do - let (n, m) = snd (bounds a) - r = listArray (0, n) [loop i 0 | i <- [0..n]] - where - loop i j | j > m = 0 - | otherwise = a!(i,j) * v!j + loop i (j + 1) - s <- evaluate $ sum (elems r) - return (r, s) -- returning both guarantees that the sum can't be - -- fused into the main computations - --- explicit inner loop w/ acc -mvm4 :: Matrix -> Vector -> IO (Vector, Float) -{-# NOINLINE mvm4 #-} -mvm4 a v = do - let (n, m) = snd (bounds a) - r = listArray (0, n) [loop i 0 0 | i <- [0..n]] - where - loop i j acc - | j > m = acc - | otherwise = loop i (j + 1) (acc + a!(i,j) * v!j) - s <- evaluate $ sum (elems r) - return (r, s) -- returning both guarantees that the sum can't be - -- fused into the main computations - --- vanilla -umvm1 :: UMatrix -> UVector -> IO (UVector, Float) -{-# NOINLINE umvm1 #-} -umvm1 a v = do - let (n, m) = snd (U.bounds a) - r = U.listArray (0, n) - [sum [a U.!(i,j) * v U.!j | j <- [0..m]] - | i <- [0..n]] - s <- evaluate $ sum (U.elems r) - return (r, s) -- returning both guarantees that the sum can't be - -- fused into the main computations - --- explicit inner loop -umvm3 :: UMatrix -> UVector -> IO (UVector, Float) -{-# NOINLINE umvm3 #-} -umvm3 a v = do - let (n, m) = snd (U.bounds a) - r = U.listArray (0, n) [loop i 0 | i <- [0..n]] - where - loop i j | j > m = 0 - | otherwise = a U.!(i,j) * v U.!j + - loop i (j + 1) - s <- evaluate $ sum (U.elems r) - return (r, s) -- returning both guarantees that the sum can't be - -- fused into the main computations - --- explicit inner loop w/ acc -umvm4a :: UMatrix -> UVector -> IO (UVector, Float) -{-# NOINLINE umvm4a #-} -umvm4a a v = do - let (n, m) = snd (U.bounds a) - r = U.listArray (0, n) [loop i 0 0 | i <- [0..n]] - where - loop i j acc - | j > m = acc - | otherwise = loop i (j + 1) - (acc + a U.!(i,j) * v U.!j) - s <- evaluate $ sum (U.elems r) - return (r, s) -- returning both guarantees that the sum can't be - -- fused into the main computations - --- explicit inner loop w/ acc forcing inlining -umvm4b :: UMatrix -> UVector -> IO (UVector, Float) -{-# NOINLINE umvm4b #-} -umvm4b a v = do - let (n, m) = snd (U.bounds a) - r = U.listArray (0, n) [loop i 0 0 | i <- [0..n]] - where - loop i j acc - | j > m = acc - | otherwise = loop i (j + 1) - (acc + a !!!(i,j) * v !!!j) - s <- evaluate $ sum (U.elems r) - return (r, s) -- returning both guarantees that the sum can't be - -- fused into the main computations - --- ST monad for array creation -umvm5 :: UMatrix -> UVector -> IO (UVector, Float) -{-# NOINLINE umvm5 #-} -umvm5 a v = do - let (n, m) = snd (U.bounds a) - r = runST (do - ma <- newArray_ (0, n) - outerLoop ma 0 - unsafeFreeze ma - ) - where - outerLoop :: STUArray s Int Float -> Int -> ST s () - outerLoop ma i - | i > n = return () - | otherwise = do - writeArray ma i (loop i 0 0) - outerLoop ma (i + 1) - loop i j acc - | j > m = acc - | otherwise = loop i (j + 1) --- (acc + a U.!(i,j) * v U.!j) - (acc + a !!!(i,j) * v !!!j) - s <- evaluate $ sum (U.elems r) - return (r, s) -- returning both guarantees that the sum can't be - -- fused into the main computations - --- Forcing the inlining of indexing -(!!!) :: (IArray a e, Ix i) => a i e -> i -> e -{-# INLINE (!!!) #-} -arr !!! i | (l,u) <- U.bounds arr = unsafeAt arr (unsafeIndex (l,u) i) ---arr !!! i | (l,u) <- U.bounds arr = unsafeAt arr (index (l,u) i) - where - index b i | U.inRange b i = unsafeIndex b i - | otherwise = error "Error in array index" - - --- merciless C code -foreign import ccall "matvecmul.h" - cmvm :: CMatrix -> CVector -> Int -> IO Float - -- returns sum only as the C compiler won't fuse the sum in to the loop - -- anyway - --- execute a function and print the result and execution time --- -execAndTime :: String -- description - -> IO Float -- benchmarked computation - -> IO () -execAndTime desc comp = - do - putStrLn $ "\n*** " ++ desc - performGC - start <- getCPUTime - result <- comp - end <- getCPUTime - let duration = (end - start) `div` 1000000000 - putStrLn $ "Result sum : " ++ show result - putStrLn $ "Running time: " ++ show duration ++ "ms" - -main :: IO () -main = do - putStrLn "Matrix vector multiplication benchmark" - putStrLn "======================================" - putStrLn $ "[time resolution: " ++ show (cpuTimePrecision `div` 1000000000)++ - "ms]" - -- - m <- generateMatrix 100 - v <- generateVector 100 - execAndTime "H98 arrays (compr) [n = 100]" (liftM snd $ mvm1 m v) - -- - m <- generateMatrix 200 - v <- generateVector 200 - execAndTime "H98 arrays (compr) [n = 200]" (liftM snd $ mvm1 m v) - execAndTime "H98 arrays (explicit inner loop) [n = 200]" - (liftM snd $ mvm3 m v) - execAndTime "H98 arrays (explicit inner loop w/ acc) [n = 200]" - (liftM snd $ mvm4 m v) - -- - m <- generateMatrix 400 - v <- generateVector 400 - execAndTime "H98 arrays (compr) [n = 400]" (liftM snd $ mvm1 m v) - execAndTime "H98 arrays (explicit inner loop) [n = 400]" - (liftM snd $ mvm3 m v) - execAndTime "H98 arrays (explicit inner loop w/ acc) [n = 400]" - (liftM snd $ mvm4 m v) - um <- arrayToIArray m - uv <- arrayToIArray v - execAndTime "UArray (compr) [n = 400]" (liftM snd $ umvm1 um uv) - execAndTime "UArray (explicit inner loop) [n = 400]" - (liftM snd $ umvm3 um uv) - execAndTime "UArray (explicit inner loop w/ acc) [n = 400]" - (liftM snd $ umvm4a um uv) - execAndTime "UArray (explicit inner loop w/ acc & inlining) [n = 400]" - (liftM snd $ umvm4b um uv) - execAndTime "UArray (ST monad and loop) [n = 400]" - (liftM snd $ umvm5 um uv) - -- - m <- generateMatrix 800 - v <- generateVector 800 - execAndTime "H98 arrays (compr) [n = 800]" (liftM snd $ mvm1 m v) - execAndTime "H98 arrays (explicit inner loop) [n = 800]" - (liftM snd $ mvm3 m v) - execAndTime "H98 arrays (explicit inner loop w/ acc) [n = 800]" - (liftM snd $ mvm4 m v) - um <- arrayToIArray m - uv <- arrayToIArray v - execAndTime "UArray (compr) [n = 800]" (liftM snd $ umvm1 um uv) - execAndTime "UArray (explicit inner loop) [n = 800]" - (liftM snd $ umvm3 um uv) - execAndTime "UArray (explicit inner loop w/ acc) [n = 800]" - (liftM snd $ umvm4a um uv) - execAndTime "UArray (explicit inner loop w/ acc & inlining) [n = 800]" - (liftM snd $ umvm4b um uv) - execAndTime "UArray (ST monad and loop) [n = 800]" - (liftM snd $ umvm5 um uv) - cm <- arrayToCArray m - cv <- arrayToCArray v - execAndTime "C [n = 800]" (cmvm cm cv 800) - -- - m <- generateMatrix 1000 - v <- generateVector 1000 - cm <- arrayToCArray m - cv <- arrayToCArray v - execAndTime "C [n = 1000]" (cmvm cm cv 1000) diff --git a/examples/ref/README b/examples/ref/README deleted file mode 100644 --- a/examples/ref/README +++ /dev/null @@ -1,2 +0,0 @@ -These are reference implementations of dot product and matrix-vector -multiplication for comparison purposes. They don't use parallel arrays. diff --git a/examples/ref/dotprod.c b/examples/ref/dotprod.c deleted file mode 100644 --- a/examples/ref/dotprod.c +++ /dev/null @@ -1,11 +0,0 @@ -// gcc -c -O6 dotprod.c - -float cvectorDP (float *v1, float *v2, int n) -{ - int i; - float sum = 0; - - for (i = 0; i < n; i++) - sum += v1[i] * v2[i]; - return sum; -} diff --git a/examples/ref/dotprod.h b/examples/ref/dotprod.h deleted file mode 100644 --- a/examples/ref/dotprod.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef DOTPROD_H -#define DOTPROD_H - -float cvectorDP (float *v1, float *v2, int n); - -#endif diff --git a/examples/ref/matvecmul.c b/examples/ref/matvecmul.c deleted file mode 100644 --- a/examples/ref/matvecmul.c +++ /dev/null @@ -1,23 +0,0 @@ -// gcc -c -O2 matvecmul.c - -#include - -float cmvm (float *m, float *v, int n) -{ - int i, j; - float *result, sum; - - result = (float*) malloc (n * sizeof (float)); - for (i = 0; i < n; i++) { - sum = 0; - for (j = 0; j < n; j++) - sum += m[i * n + j] * v[j]; - result[i] = sum; - } - - sum = 0; - for (i = 0; i < n; i++) - sum += result[i]; - - return sum; -} diff --git a/examples/ref/matvecmul.h b/examples/ref/matvecmul.h deleted file mode 100644 --- a/examples/ref/matvecmul.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef MATVECMUL_H -#define MATVECMUL_H - -float cmvm (float *v1, float *v2, int n); - -#endif diff --git a/examples/simple/DotProd.hs b/examples/simple/DotProd.hs deleted file mode 100644 --- a/examples/simple/DotProd.hs +++ /dev/null @@ -1,46 +0,0 @@ -module DotProd -where - -import Data.Array.Parallel.Unlifted - -test :: UArr Float -> UArr Float -> Float -test v w = loopAcc - . loopU (\a (x:*:y) -> (a + x * y :*: (Nothing::Maybe ()))) 0 - $ zipU v w - - -{- Inner loop: - - poly_$wtrans_s15C :: forall s1_aZb. - GHC.Prim.Int# - -> GHC.Base.Int - -> GHC.Prim.Float# - -> GHC.Prim.State# s1_aZb - -> (# GHC.Prim.State# s1_aZb, (GHC.Float.Float, GHC.Base.Int) #) - [Arity 4] - poly_$wtrans_s15C = - \ (@ s1_X10d) - (ww_X164 :: GHC.Prim.Int#) - (w1_X167 :: GHC.Base.Int) - (ww1_X16b :: GHC.Prim.Float#) - (w2_X16e :: GHC.Prim.State# s1_X10d) -> - case GHC.Prim.==# ww_X164 wild2_B1 of wild4_XVx { - GHC.Base.False -> - poly_$wtrans_s15C - @ s1_X10d - (GHC.Prim.+# ww_X164 1) - w1_X167 - (GHC.Prim.plusFloat# - ww1_X16b - (GHC.Prim.timesFloat# - (GHC.Prim.indexFloatArray# rb2_aXC (GHC.Prim.+# rb_aXx ww_X164)) - (GHC.Prim.indexFloatArray# rb21_X11Y (GHC.Prim.+# rb11_X11T ww_X164)))) - w2_X16e; - GHC.Base.True -> - case w1_X167 of tpl_aZj { GHC.Base.I# a1_aZk -> - (# w2_X16e, ((GHC.Float.F# ww1_X16b), tpl_aZj) #) - } - }; - } in - --} diff --git a/examples/simple/MapInc.hs b/examples/simple/MapInc.hs deleted file mode 100644 --- a/examples/simple/MapInc.hs +++ /dev/null @@ -1,34 +0,0 @@ -module MapInc -where - -import Data.Array.Parallel.Unlifted - -test :: UArr Int -> UArr Int -test = loopArr . loopU (\_ x -> (() :*: (Just $ x + 1 :: Maybe Int))) () - - -{- Inner loop: - - $wtrans_sVe = - \ (ww_sUI :: GHC.Prim.Int#) - (ww1_sUM :: GHC.Prim.Int#) - (w_sUO :: ()) - (w1_sUP :: GHC.Prim.State# s_aIR) -> - case GHC.Prim.==# ww_sUI rb1_aUd of wild12_aHq { - GHC.Base.False -> - case GHC.Prim.writeIntArray# - @ s_aIR - marr#_aOV - ww1_sUM - (GHC.Prim.+# (GHC.Prim.indexIntArray# rb2_aUe (GHC.Prim.+# rb_aL4 ww_sUI)) 1) - w1_sUP - of s2#1_aRq { __DEFAULT -> - $wtrans_sVe (GHC.Prim.+# ww_sUI 1) (GHC.Prim.+# ww1_sUM 1) GHC.Base.() s2#1_aRq - }; - GHC.Base.True -> - case w_sUO of tpl1_aJ1 { () -> - (# w1_sUP, (GHC.Base.(), (GHC.Base.I# ww1_sUM)) #) - } - }; - --} diff --git a/examples/simple/PrefixSum.hs b/examples/simple/PrefixSum.hs deleted file mode 100644 --- a/examples/simple/PrefixSum.hs +++ /dev/null @@ -1,38 +0,0 @@ -module PrefixSum -where - -import Data.Array.Parallel.Unlifted - -test :: UArr Int -> UArr Int -test = loopArr . loopU (\a x -> (a + x :*: Just a)) 0 - - -{- Inner loop: - - $wtrans_sV2 :: GHC.Prim.Int# - -> GHC.Prim.Int# - -> GHC.Prim.Int# - -> GHC.Prim.State# s_aIq - -> (# GHC.Prim.State# s_aIq, (GHC.Base.Int, GHC.Base.Int) #) - [Arity 4 - Str: DmdType LLLL] - $wtrans_sV2 = - \ (ww_sUt :: GHC.Prim.Int#) - (ww1_sUx :: GHC.Prim.Int#) - (ww2_sUB :: GHC.Prim.Int#) - (w_sUD :: GHC.Prim.State# s_aIq) -> - case GHC.Prim.==# ww_sUt rb1_aU1 of wild12_aH7 { - GHC.Base.False -> - case GHC.Prim.writeIntArray# @ s_aIq marr#_aOv ww1_sUx ww2_sUB w_sUD - of s2#1_aRd { __DEFAULT -> - $wtrans_sV2 - (GHC.Prim.+# ww_sUt 1) - (GHC.Prim.+# ww1_sUx 1) - (GHC.Prim.+# - ww2_sUB (GHC.Prim.indexIntArray# rb2_aU2 (GHC.Prim.+# rb_aKE ww_sUt))) - s2#1_aRd - }; - GHC.Base.True -> (# w_sUD, ((GHC.Base.I# ww2_sUB), (GHC.Base.I# ww1_sUx)) #) - }; - --} diff --git a/examples/simple/SegPrefixSum.hs b/examples/simple/SegPrefixSum.hs deleted file mode 100644 --- a/examples/simple/SegPrefixSum.hs +++ /dev/null @@ -1,106 +0,0 @@ -module SegPrefixSum -where - -import Data.Array.Parallel.Unlifted - -test :: SUArr Int -> SUArr Int -test = fstS - . loopArr - . loopSU (\a x -> ((a + x::Int) :*: Just a)) - (\a i -> (a :*: (Nothing :: Maybe ()))) 0 - - -{- Inner loop: - - $wtrans_s1aH :: GHC.Prim.Int# - -> GHC.Prim.Int# - -> GHC.Prim.Int# - -> GHC.Prim.Int# - -> GHC.Prim.Int# - -> GHC.Prim.State# s_aLt - -> (# GHC.Prim.State# s_aLt, (GHC.Base.Int, GHC.Base.Int) #) - [Arity 6 - Str: DmdType LLLLLL] - $wtrans_s1aH = - \ (ww7_s19k :: GHC.Prim.Int#) - (ww8_s19o :: GHC.Prim.Int#) - (ww9_s19s :: GHC.Prim.Int#) - (ww10_s19w :: GHC.Prim.Int#) - (ww11_s19A :: GHC.Prim.Int#) - (w_s19C :: GHC.Prim.State# s_aLt) -> - case ww8_s19o of wild14_X1X { - __DEFAULT -> - case GHC.Prim.readIntArray# @ s_aLt marr#1_XQl ww9_s19s w_s19C - of wild2_aVH { (# s2#3_aVJ, r#_aVK #) -> - case GHC.Prim.readIntArray# @ s_aLt marr#_aPk ww9_s19s s2#3_aVJ - of wild21_XXy { (# s2#4_XXB, r#1_XXD #) -> - case GHC.Prim.writeIntArray# - @ s_aLt marr#2_XQt (GHC.Prim.+# r#_aVK r#1_XXD) ww11_s19A s2#4_XXB - of s2#5_aWC { __DEFAULT -> - case GHC.Prim.writeIntArray# - @ s_aLt marr#_aPk ww9_s19s (GHC.Prim.+# r#1_XXD 1) s2#5_aWC - of s2#6_XZ5 { __DEFAULT -> - $wtrans_s1aH - (GHC.Prim.+# ww7_s19k 1) - (GHC.Prim.-# wild14_X1X 1) - ww9_s19s - ww10_s19w - (GHC.Prim.+# - ww11_s19A (GHC.Prim.indexIntArray# rb2_aOg (GHC.Prim.+# rb_aOd ww7_s19k))) - s2#6_XZ5 - } - } - } - }; - 0 -> - let { - a_s10T [Just L] :: GHC.Prim.Int# - [Str: DmdType] - a_s10T = GHC.Prim.+# ww9_s19s 1 - } in - case GHC.Prim.==# a_s10T ww1_s19O of wild3_aLw { - GHC.Base.False -> - case a_s10T of wild2_X3e { - __DEFAULT -> - case GHC.Prim.readIntArray# @ s_aLt marr#1_XQl (GHC.Prim.-# wild2_X3e 1) w_s19C - of wild21_aVH { (# s2#3_aVJ, r#_aVK #) -> - case GHC.Prim.readIntArray# @ s_aLt marr#_aPk (GHC.Prim.-# wild2_X3e 1) s2#3_aVJ - of wild22_XXY { (# s2#4_XY1, r#1_XY3 #) -> - case GHC.Prim.writeIntArray# - @ s_aLt marr#1_XQl wild2_X3e (GHC.Prim.+# r#_aVK r#1_XY3) s2#4_XY1 - of s2#5_aWC { __DEFAULT -> - case GHC.Prim.writeIntArray# @ s_aLt marr#_aPk wild2_X3e 0 s2#5_aWC - of s2#6_XYN { __DEFAULT -> - $wtrans_s1aH - ww7_s19k - (GHC.Prim.indexIntArray# ww2_s19P (GHC.Prim.+# ww_s19N wild2_X3e)) - wild2_X3e - ww10_s19w - ww11_s19A - s2#6_XYN - } - } - } - }; - 0 -> - case GHC.Prim.writeIntArray# @ s_aLt marr#1_XQl 0 0 w_s19C - of s2#3_aWC { __DEFAULT -> - case GHC.Prim.writeIntArray# @ s_aLt marr#_aPk 0 0 s2#3_aWC - of s2#4_XYN { __DEFAULT -> - $wtrans_s1aH - ww7_s19k - (GHC.Prim.indexIntArray# ww2_s19P ww_s19N) - 0 - ww10_s19w - ww11_s19A - s2#4_XYN - } - } - }; - GHC.Base.True -> - (# w_s19C, ((GHC.Base.I# ww10_s19w), (GHC.Base.I# ww11_s19A)) #) - } - }; - } in - --} diff --git a/examples/simple/SegSum.hs b/examples/simple/SegSum.hs deleted file mode 100644 --- a/examples/simple/SegSum.hs +++ /dev/null @@ -1,129 +0,0 @@ -module SegSum -where - -import Data.Array.Parallel.Unlifted - -test :: SUArr Int -> UArr Int -test = sndS - . loopArr - . loopSU (\a x -> ((a + x::Int) :*: (Nothing::Maybe ()))) - (\a i -> (a :*: Just a)) 0 - -{- Inner loop: - - $wtrans_s19S :: GHC.Prim.Int# - -> GHC.Prim.Int# - -> GHC.Prim.Int# - -> GHC.Prim.Int# - -> GHC.Prim.Int# - -> GHC.Prim.State# s_aLn - -> (# GHC.Prim.State# s_aLn, (GHC.Base.Int, GHC.Base.Int) #) - [Arity 6 - Str: DmdType LLLLLL] - $wtrans_s19S = - \ (ww_s18Y :: GHC.Prim.Int#) - (ww1_s192 :: GHC.Prim.Int#) - (ww2_s196 :: GHC.Prim.Int#) - (ww3_s19a :: GHC.Prim.Int#) - (ww4_s19e :: GHC.Prim.Int#) - (w_s19g :: GHC.Prim.State# s_aLn) -> - case ww1_s192 of wild2_X1p { - __DEFAULT -> - $wtrans_s19S - (GHC.Prim.+# ww_s18Y 1) - (GHC.Prim.-# wild2_X1p 1) - ww2_s196 - ww3_s19a - (GHC.Prim.+# - ww4_s19e (GHC.Prim.indexIntArray# rb21_aO7 (GHC.Prim.+# rb11_aO4 ww_s18Y))) - w_s19g; - 0 -> - let { - $w$j_s19W :: GHC.Prim.State# s_aLn - -> GHC.Prim.Int# - -> GHC.Prim.Int# - -> (# GHC.Prim.State# s_aLn, (GHC.Base.Int, GHC.Base.Int) #) - [Arity 3 - Str: DmdType LLL] - $w$j_s19W = - \ (w1_s18H :: GHC.Prim.State# s_aLn) - (ww5_s18M :: GHC.Prim.Int#) - (ww6_s18Q :: GHC.Prim.Int#) -> - let { - a_s104 [Just L] :: GHC.Prim.Int# - [Str: DmdType] - a_s104 = GHC.Prim.+# ww2_s196 1 - } in - case GHC.Prim.==# a_s104 rb1_aJe of wild3_aLq { - GHC.Base.False -> - case a_s104 of wild31_X2J { - __DEFAULT -> - case GHC.Prim.readIntArray# - @ s_aLn marr#1_XPR (GHC.Prim.-# wild31_X2J 1) w1_s18H - of wild21_aXE { (# s2#3_aXG, r#_aXH #) -> - case GHC.Prim.readIntArray# - @ s_aLn marr#_aOP (GHC.Prim.-# wild31_X2J 1) s2#3_aXG - of wild22_XZY { (# s2#4_X101, r#1_X103 #) -> - case GHC.Prim.writeIntArray# - @ s_aLn marr#1_XPR wild31_X2J (GHC.Prim.+# r#_aXH r#1_X103) s2#4_X101 - of s2#5_aVX { __DEFAULT -> - case GHC.Prim.writeIntArray# @ s_aLn marr#_aOP wild31_X2J 0 s2#5_aVX - of s2#6_XYb { __DEFAULT -> - $wtrans_s19S - ww_s18Y - (GHC.Prim.indexIntArray# rb2_aJf (GHC.Prim.+# rb_aIC wild31_X2J)) - wild31_X2J - ww5_s18M - ww6_s18Q - s2#6_XYb - } - } - } - }; - 0 -> - case GHC.Prim.writeIntArray# @ s_aLn marr#1_XPR 0 0 w1_s18H - of s2#3_aVX { __DEFAULT -> - case GHC.Prim.writeIntArray# @ s_aLn marr#_aOP 0 0 s2#3_aVX - of s2#4_XYb { __DEFAULT -> - $wtrans_s19S - ww_s18Y - (GHC.Prim.indexIntArray# rb2_aJf rb_aIC) - 0 - ww5_s18M - ww6_s18Q - s2#4_XYb - } - } - }; - GHC.Base.True -> (# w1_s18H, ((GHC.Base.I# ww5_s18M), (GHC.Base.I# ww6_s18Q)) #) - } - } in - case ww2_s196 of wild3_X1P { - __DEFAULT -> - case GHC.Prim.writeIntArray# @ s_aLn marr#2_XQ3 ww3_s19a ww4_s19e w_s19g - of s2#3_aVX { __DEFAULT -> - $w$j_s19W s2#3_aVX (GHC.Prim.+# ww3_s19a 1) ww4_s19e - }; - (-1) -> $w$j_s19W w_s19g ww3_s19a ww4_s19e - } - }; - - -The matching C routine: - -void test (int arr[], int segd[], int n, int m, int out[], int *len) -{ - int acc = 0; - int arr_i, segd_i, seg_cnt; - - arr_i = 0; - for (segd_i = 0; segd_i < m; segd_i++) { - acc = 0; - for (seg_cnt = segd[segd_i]; seg_cnt == 0; seg_cnt--) - acc += arr[arr_i++]; - out[segd_i] = acc; - } - *len = m; -} - --} diff --git a/examples/simple/Sum.hs b/examples/simple/Sum.hs deleted file mode 100644 --- a/examples/simple/Sum.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Sum -where - -import Data.Array.Parallel.Unlifted - -test :: UArr Int -> Int -test = loopAcc . loopU (\a x -> (a + x :*: (Nothing::Maybe ()))) 0 - - -{- Inner loop: - - poly_$wtrans_sPp :: forall s1_aIm. - GHC.Prim.Int# - -> GHC.Base.Int - -> GHC.Prim.Int# - -> GHC.Prim.State# s1_aIm - -> (# GHC.Prim.State# s1_aIm, (GHC.Base.Int, GHC.Base.Int) #) - [Arity 4] - poly_$wtrans_sPp = - \ (@ s1_XJ3) - (ww_XPz :: GHC.Prim.Int#) - (w_XPC :: GHC.Base.Int) - (ww1_XPG :: GHC.Prim.Int#) - (w1_XPJ :: GHC.Prim.State# s1_XJ3) -> - case GHC.Prim.==# ww_XPz wild11_B1 of wild2_XHP { - GHC.Base.False -> - poly_$wtrans_sPp - @ s1_XJ3 - (GHC.Prim.+# ww_XPz 1) - w_XPC - (GHC.Prim.+# - ww1_XPG (GHC.Prim.indexIntArray# rb2_aPT (GHC.Prim.+# rb_aKA ww_XPz))) - w1_XPJ; - GHC.Base.True -> - case w_XPC of tpl_aIu { GHC.Base.I# a1_aIv -> - (# w1_XPJ, ((GHC.Base.I# ww1_XPG), tpl_aIu) #) - } - }; - --} diff --git a/examples/smvm/Makefile b/examples/smvm/Makefile deleted file mode 100644 --- a/examples/smvm/Makefile +++ /dev/null @@ -1,9 +0,0 @@ -TESTDIR = .. -PROGS = mksm smvm-c smvm -HCCFLAGS = -optc-O3 -include $(TESTDIR)/mk/test.mk - -smvm.o: SMVMPar.hi SMVMSeq.hi SMVMVect.hi - -smvm: smvm.o SMVMPar.o SMVMSeq.o SMVMVect.o - diff --git a/examples/smvm/README b/examples/smvm/README deleted file mode 100644 --- a/examples/smvm/README +++ /dev/null @@ -1,43 +0,0 @@ -Mutliplication of a sparse matrix with a dense vector -===================================================== - -This is the algorithm discussed in "Data Parallel Haskell: a status report" -(http://www.cse.unsw.edu.au/~chak/papers/CLPKM07.html). See also -http://www.cs.cmu.edu/~scandal/nesl/alg-numerical.html#mvmult. - -smvm --help displays the available options. - -Generating test data --------------------- - -mksm COLS ROWS RATION FILE - -generates a test matrix with COLS columns and ROWS rows and writes it to FILE. -RATIO determines the fill ration; e.g., 0.1 here generates a matrix with 9 out -10 of elements being zero. - -WARNING: The generated files can be quite large. For instance, a 10000x10000 -matrix with a fill ratio of 0.1 (i.e. with approx. 10 millions non-zero -elements) is over 150MB on my computer. Also, the files binary, i.e., they -have to be regenerated for every new architecture. Matrix generation can take -quite a long time as it is not optimised at all. - -Sequential C benchmark ----------------------- - -smvm-c FILE - -Benchmark ---------- - -smvm --help displays the available options. - -The following algorithms are supported: - - smvms - sequential implementation - smvmp - parallel implementation - - -No parallel implementation is available yet as the library is missing -functionality. - diff --git a/examples/smvm/SMVMPar.hs b/examples/smvm/SMVMPar.hs deleted file mode 100644 --- a/examples/smvm/SMVMPar.hs +++ /dev/null @@ -1,13 +0,0 @@ -module SMVMPar -where - -import Data.Array.Parallel.Unlifted.Parallel -import Data.Array.Parallel.Unlifted - -type SparseMatrix = SUArr (Int :*: Double) -type SparseVector = UArr (Int :*: Double) -type Vector = UArr Double - -smvm :: SparseMatrix -> Vector -> Vector -smvm sm v = sumSUP (zipWithSUP (*) (bpermuteSUP' v (fstSU sm)) (sndSU sm)) - diff --git a/examples/smvm/SMVMSeq.hs b/examples/smvm/SMVMSeq.hs deleted file mode 100644 --- a/examples/smvm/SMVMSeq.hs +++ /dev/null @@ -1,12 +0,0 @@ -module SMVMSeq -where - -import Data.Array.Parallel.Unlifted - -type SparseMatrix = SUArr (Int :*: Double) -type SparseVector = UArr (Int :*: Double) -type Vector = UArr Double - -smvm :: SparseMatrix -> Vector -> Vector -smvm sm v = sumSU (zipWithSU (*) (bpermuteSU' v (fstSU sm)) (sndSU sm)) - diff --git a/examples/smvm/SMVMVect.hs b/examples/smvm/SMVMVect.hs deleted file mode 100644 --- a/examples/smvm/SMVMVect.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE PArr #-} -{-# OPTIONS -fvectorise #-} -module SMVMVect (smvm) where - -import Data.Array.Parallel.Prelude -import Data.Array.Parallel.Prelude.Double -import Data.Array.Parallel.Prelude.Int (Int) - -import qualified Prelude - -smvm :: PArray (PArray (Int, Double)) -> PArray Double -> PArray Double -{-# NOINLINE smvm #-} -smvm m v = toPArrayP (smvm' (fromNestedPArrayP m) (fromPArrayP v)) - -smvm' :: [:[: (Int, Double) :]:] -> [:Double:] -> [:Double:] -smvm' m v = [: sumP [: x * (v !: i) | (i,x) <- row :] | row <- m :] - diff --git a/examples/smvm/mksm.c b/examples/smvm/mksm.c deleted file mode 100644 --- a/examples/smvm/mksm.c +++ /dev/null @@ -1,187 +0,0 @@ -#include -#include -#include -#include -#include -#include - -#include - -HsInt cols; -HsInt rows; -double ratio; - -HsInt *lengths; -HsInt *indices; - -enum { FLOAT, DOUBLE } type; - -HsDouble gen_doubles( int file, HsInt n ) -{ - HsDouble d; - HsDouble sum = 0; - - int a, b; - - while( n != 0 ) - { - a = random() % 1000; - b = random() % 1000; - if (a == 0 || b == 0) - d = 0.1; - else - d = ((HsDouble)a) / ((HsDouble)b); - - write( file, &d, sizeof(HsDouble) ); - sum += d; - --n; - } - return sum; -} - -HsFloat gen_floats( int file, HsInt n ) -{ - HsFloat d; - HsFloat sum = 0; - - int a, b; - - while( n != 0 ) - { - a = random() % 1000; - b = random() % 1000; - if (a == 0 || b == 0) - d = 0.1; - else - d = ((HsFloat)a) / ((HsFloat)b); - - write( file, &d, sizeof(HsFloat) ); - sum += d; - --n; - } - return sum; -} - - -HsInt gen_lengths() -{ - HsInt i; - HsInt n = 0; - - int range = ((double)cols * 2) * ratio; - - for( i = 0; i < rows; ++i ) { - lengths[i] = random() % range; - n += lengths[i]; - } - - return n; -} - -int find_index( int from, int to, HsInt idx ) -{ - while( from != to ) { - if( indices[from] == idx ) return 1; - ++from; - } - return 0; -} - -int cmp_HsInt( const void *p, const void *q ) -{ - HsInt x = *(HsInt *)p; - HsInt y = *(HsInt *)q; - - if( x < y ) return -1; - if( x > y ) return 1; - return 0; -} - -void gen_indices( int file ) -{ - HsInt i, j, k; - - k = 0; - for( i = 0; i < rows; ++i ) { - for( j = 0; j < lengths[i]; ++j ) { - do { - indices[j] = random() % cols; - } while( find_index( 0, j, indices[j] ) ); - } - qsort( indices, j, sizeof(HsInt), cmp_HsInt ); - write( file, indices, sizeof(HsInt) * j ); - } -} - -int usage() -{ - puts( "mksm [float|double] COLS ROWS RATIO FILE" ); - exit(1); -} - -int main( int argc, char *argv[] ) -{ - HsInt n; - - int file; - int arg; - - HsDouble sum1,sum2; - - if( argc == 1 || argc < 5 ) - usage(); - - if( isdigit( argv[1][0] ) ) - { - arg = 1; - type = DOUBLE; - } - else - { - arg = 2; - if( !strcmp( argv[1], "float" ) ) - type = FLOAT; - else if( !strcmp( argv[1], "double" ) ) - type = DOUBLE; - else - { - fputs( "Invalid type\n", stderr ); - usage(); - } - } - - cols = atoi( argv[arg++] ); - rows = atoi( argv[arg++] ); - ratio = atof( argv[arg++] ); - - lengths = (HsInt *)malloc( rows * sizeof(HsInt) ); - indices = (HsInt *)malloc( cols * sizeof(HsInt) ); - - if( arg >= argc ) - usage(); - - file = creat( argv[arg], 0666 ); - - n = gen_lengths(); - write( file, &rows, sizeof(rows) ); - write( file, lengths, sizeof(HsInt) * rows ); - write( file, &n, sizeof(n) ); - gen_indices( file ); - write( file, &n, sizeof(n) ); - if( type == DOUBLE ) - sum1 = gen_doubles(file, n); - else - sum1 = (HsDouble)gen_floats(file, n); - write( file, &cols, sizeof(cols) ); - if( type == DOUBLE ) - sum2 = gen_doubles(file, cols); - else - sum2 = (HsDouble)gen_floats(file, n); - close(file); - - printf( "columns = %d; rows = %d; elements = %d (%d)\n", cols, rows, n, - (int)(type == FLOAT ? sizeof(HsFloat) : sizeof(HsDouble)) ); - printf( "%Lf %Lf\n", (long double)sum1, (long double)sum2 ); - return 0; -} - diff --git a/examples/smvm/smvm-c.c b/examples/smvm/smvm-c.c deleted file mode 100644 --- a/examples/smvm/smvm-c.c +++ /dev/null @@ -1,89 +0,0 @@ -#include -#include -#include -#include -#include - -#include - -int rows; -int cols; - -typedef struct { - HsInt size; - void *data; -} Array; - -Array vector; -Array lengths; -Array indices; -Array values; -Array result; - -#define DATA(arr,i,t) (((t *)(arr).data)[i]) - -void new( HsInt size, Array * arr, int el_size ) -{ - arr->size = size; - arr->data = malloc( el_size * size ); -} - -void load( int file, Array * arr, int el_size ) -{ - read( file, &(arr->size), sizeof(HsInt) ); - arr->data = malloc( el_size * arr->size ); - read( file, arr->data, arr->size*el_size ); -} - -void compute() -{ - HsInt row, el, idx; - HsDouble sum; - - el = 0; - idx = 0; - for( row = 0; row < lengths.size; ++row ) { - sum = 0; - for( el = 0; el < DATA(lengths,row,HsInt); ++el ) { - sum += DATA(values, idx, HsDouble) - * DATA(vector, DATA(indices, idx, HsInt), HsDouble); - ++idx; - } - DATA(result, row, HsDouble) = sum; - } -} - -HsDouble checksum( Array * arr ) -{ - HsDouble sum = 0; - int i; - - for( i = 0; i < arr->size; ++i ) - sum += DATA((*arr), i, HsDouble); - return sum; -} - -int main( int argc, char * argv[] ) -{ - int file; - clock_t start, finish; - - file = open( argv[1], O_RDONLY ); - load( file, &lengths, sizeof(HsInt) ); - load( file, &indices, sizeof(HsInt) ); - load( file, &values, sizeof(HsDouble) ); - load( file, &vector, sizeof(HsDouble) ); - close(file); - new( lengths.size, &result, sizeof(HsDouble) ); - - printf( "rows = %ld; colums = %ld; elements = %ld\n", (long)lengths.size - , (long)vector.size - , (long)values.size ); - start = clock(); - compute(); - finish = clock(); - - printf( "%ld %Lf\n", (long int)((finish-start) / (CLOCKS_PER_SEC/1000)), - (long double)(checksum(&result)) ); -} - diff --git a/examples/smvm/smvm.hs b/examples/smvm/smvm.hs deleted file mode 100644 --- a/examples/smvm/smvm.hs +++ /dev/null @@ -1,84 +0,0 @@ -import Data.Array.Parallel.Unlifted -import Data.Array.Parallel.Unlifted.Distributed -import Data.Array.Parallel.Prelude -import qualified SMVMPar -import qualified SMVMSeq -import qualified SMVMVect ---import Timing - -import System.Console.GetOpt -import System.IO -{- -import System.Exit -import System.Environment (getArgs) --} -import Control.Exception (evaluate) -{- -import System.Mem (performGC) --} - -import Bench.Benchmark -import Bench.Options - -type Alg = SUArr (Int :*: Double) -> UArr Double -> UArr Double - -algs = [("smvmp", SMVMPar.smvm) - ,("smvms", SMVMSeq.smvm) - ,("smvmv", smvm_vect) - ] - -smvm_vect m v = toUArrPA (SMVMVect.smvm (fromSUArrPA_2' m) (fromUArrPA' v)) - -main = ndpMain "Sparse matrix/vector multiplication" - "[OPTION] ... FILE ..." - run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") - "use the specified algorithm"] - "smvmp" - -run opts alg files = - case lookup alg algs of - Just f -> procFiles opts f files - Nothing -> failWith ["Unknown algorithm " ++ alg] - -procFiles :: Options -> Alg -> [String] -> IO () -procFiles opts alg fs = - do - benchmark opts - (uncurry alg) - (map loadSM fs) - showRes - return () - where - arg s = (cols, rows, ratio) - where - ((cols,('x':s')):_) = reads s - ((rows,('@':s'')):_) = reads s' - ratio = read s'' - - showRes arr = "sum=" ++ show (sumU arr) - -loadSM :: String -> IO (Point (SUArr (Int :*: Double), UArr Double)) -loadSM s@('(' : _) = - case reads s of - [((lm,lv), "")] -> return $ mkPoint "input" (toSU lm, toU lv) - _ -> failWith ["Invalid data " ++ s] -loadSM fname = - do - h <- openBinaryFile fname ReadMode - lengths <- hGetU h - indices <- hGetU h - values <- hGetU h - dv <- hGetU h - let sm = lengthsToUSegd lengths >: zipU indices values - return (sm, values) - evaluate lengths - evaluate indices - evaluate values - evaluate dv - -- print (sumU values) - -- print (sumU dv) - return $ mkPoint ( "cols=" ++ show (lengthU dv) ++ ", " - ++ "rows=" ++ show (lengthSU sm) ++ ", " - ++ "elems=" ++ show (lengthU (concatSU sm))) - (sm,dv) - diff --git a/examples/spec-constr/Makefile b/examples/spec-constr/Makefile deleted file mode 100644 --- a/examples/spec-constr/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -TESTDIR = .. -PROGS = spec-constr -include $(TESTDIR)/mk/test.mk - -spec-constr.o: Pipelines.hi - -spec-constr: Pipelines.o $(BENCHLIB) - diff --git a/examples/spec-constr/Pipelines.hs b/examples/spec-constr/Pipelines.hs deleted file mode 100644 --- a/examples/spec-constr/Pipelines.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Pipelines where - -import Data.Array.Parallel.Unlifted - -pipe1 :: UArr Int -> UArr Int -> UArr Int -pipe1 xs ys = mapU (+1) (xs +:+ ys) -{-# NOINLINE pipe1 #-} - -pipe2 :: UArr Int -> UArr Int -pipe2 = mapU (+1) . tailU -{-# NOINLINE pipe2 #-} - -pipe3 :: UArr Int -> Int -pipe3 = maximumU . scan1U (+) -{-# NOINLINE pipe3 #-} - -pipe4 :: SUArr Int -> Int -pipe4 = maximumU . sumSU -{-# NOINLINE pipe4 #-} - -pipe5 :: UArr Int -> UArr Int -{-# NOINLINE pipe5 #-} -pipe5 xs = sumSU (replicateSU (replicateU (lengthU xs) 5) xs) - diff --git a/examples/spec-constr/spec-constr.hs b/examples/spec-constr/spec-constr.hs deleted file mode 100644 --- a/examples/spec-constr/spec-constr.hs +++ /dev/null @@ -1,69 +0,0 @@ -import Data.Array.Parallel.Unlifted - -import Bench.Benchmark -import Bench.Options - -import System.Random -import System.Console.GetOpt - -import Pipelines as P - -type Gen a = forall g. RandomGen g => Int -> g -> IO a - -data Algo = forall a b. Algo (a -> b) (Gen a) - -algs :: [(String, Algo)] -algs = [("pipe1", Algo (uncurry pipe1) (uarr >< uarr)) - ,("pipe2", Algo pipe2 uarr) - ,("pipe3", Algo pipe3 uarr) - ,("pipe4", Algo pipe4 suarr) - ,("pipe5", Algo pipe5 uarr) - ] - -uarr :: (UA a, Random a) => Gen (UArr a) -uarr n g = return $! randomU n g - -suarr :: (UA a, Random a) => Gen (SUArr a) -suarr n g = - do let lens = replicateU (n `div` 10) (10 :: Int) - segd = lengthsToUSegd lens - n' = (n `div` 10) * 10 - arr = randomU n' g - segd `seq` arr `seq` return (segd >: arr) - -(><) :: Gen a -> Gen b -> Gen (a,b) -(h1 >< h2) n g = let (g1,g2) = split g - in - do x <- h1 n g1 - y <- h2 n g2 - return (x,y) - -randomGens :: RandomGen g => Int -> g -> [g] -randomGens 0 g = [] -randomGens n g = let (g1,g2) = split g - in g1 : randomGens (n-1) g2 - -main = ndpMain "SpecConstr test" - "[OPTION] ... SIZE" - run [Option ['a'] ["algo"] (ReqArg const "ALGORITHM") - "use the selected algorithm"] - "" - -run opts alg sizes = - case lookup alg algs of - Nothing -> failWith ["Unknown algorithm"] - Just (Algo f gen) -> - case map read sizes of - [] -> failWith ["No sizes specified"] - szs -> do - g <- getStdGen - let gs = randomGens (length szs) g - benchmark opts f - (zipWith (mk gen) szs gs) - (const "") - return () - where - mk gen n g = do - x <- gen n g - return $ ("N = " ++ show n) `mkPoint` x - diff --git a/examples/sumsq/SumSq.hs b/examples/sumsq/SumSq.hs deleted file mode 100644 --- a/examples/sumsq/SumSq.hs +++ /dev/null @@ -1,14 +0,0 @@ --- the infamous sum square fusion example - -module Main (main) -where - -import Data.Array.Parallel.Unlifted - -sumSq :: Int -> Int -{-# NOINLINE sumSq #-} ---sumSq = sumP . mapP (\x -> x * x) . enumFromToP 1 -sumSq n = sumU (mapU (\x -> x * x) (enumFromToU 1 n)) - -main = print $ sumSq 100 - diff --git a/examples/unit/TestBUArr.hs b/examples/unit/TestBUArr.hs deleted file mode 100644 --- a/examples/unit/TestBUArr.hs +++ /dev/null @@ -1,19 +0,0 @@ -import Data.Array.Parallel.Arr.BUArr - -replicateBU_test :: UAE e => Int -> e -> BUArr e -replicateBU_test n e = - runST (do - arr <- newMBU n - fill arr n - unsafeFreezeMBU arr n - ) - where - fill arr 0 = return () - fill arr i = - do - let i' = i - 1 - writeMBU arr i' e - fill arr i' - - -main = print $ sumBU (replicateBU_test 5 (10 :: Int)) diff --git a/examples/unit/TestUArr.hs b/examples/unit/TestUArr.hs deleted file mode 100644 --- a/examples/unit/TestUArr.hs +++ /dev/null @@ -1,30 +0,0 @@ -import Data.Array.Parallel.Base.BUArr (ST, runST) -import Data.Array.Parallel.Monadic.UArr - -replicateU :: UA e => Int -> e -> UArr e -replicateU n e = - runST (do - arr <- newMU n - fill arr n - unsafeFreezeMU arr n - ) - where - fill arr 0 = return () - fill arr i = - do - let i' = i - 1 - writeMU arr i' e - fill arr i' - -sumU :: (Num e, UA e) => UArr e -> e -sumU arr = sumUp (lengthU arr) 0 - where - sumUp 0 acc = acc - sumUp i acc = - let - i' = i - 1 - acc' = acc + arr `indexU` i' - in - acc' `seq` sumUp i' acc' - -main = print $ sumU (replicateU 5 (10 :: Int)) diff --git a/tests/Examples/Test.hs b/tests/Examples/Test.hs deleted file mode 100644 --- a/tests/Examples/Test.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ < 610 -import System.Process -import qualified Control.Exception as C -#else -import System.Process hiding (readProcess) -import qualified Control.OldException as C -#endif - -import System.Exit -import System.IO -import Data.List -import Data.Maybe -import System.Directory - -import Control.Monad -import Control.Concurrent -import Text.Printf - -import Text.Regex.PCRE.Light.Char8 - ------------------------------------------------------------------------- - -flags= [["-O","-fspec-constr"] - ,["-O2"] - ] - -tests = - [(Just 4, "prod", flags ) -- expect 2 fusions, with -O2 and -O - ,(Just 2, "fuse", flags ) - ,(Just 4, "real2Frac", flags ) - ] - ------------------------------------------------------------------------- - -main = do - printf "Running %d fusion tests.\n" (length tests) - vs <- forM tests $ \x -> do v <- run x - putChar '\n' - return v - printf "\nDone.\n" - if not (and vs) - then exitWith (ExitFailure 1) - else return () - -run :: (Maybe Int, String, [[String]]) -> IO Bool -run (n, name, args) = do - printf "%10s: " name >> hFlush stdout - v <- forM args $ \opt -> do - putChar '.' >> hFlush stdout - (cmd,ex,fusion) <- compile_program name opt - if ex /= n - then do - printf "\n%s failed to trigger fusion. Expected %s, Actual %s.\n" - name (show n) (show ex) - printf "Command line: %s\n" (show $ intercalate " " cmd) - return False - else - if isJust fusion - then do - printf "\n%s failed to remove all vectors.\n" name - printf "Remnants: %s\n" (show fusion) - printf "Command line: %s\n" (show $ intercalate " " cmd) - return False - else return True - return (and v) - ------------------------------------------------------------------------- - -compile_program s opt = do - - let command = [(s ++ ".hs"), "-ddump-simpl","-ddump-simpl-stats","-no-recomp","--make"] ++ opt - x <- readProcess "ghc" command [] - removeFile s - case x of - Left (err,str) -> do - print str - printf "GHC failed to compile %s\n" s - exitWith (ExitFailure 1) -- fatal - - Right str -> do - return $ case match fusion_regex str [] of - Nothing -> (command,Nothing,Nothing) - Just xs -> - let fusion_result = (read $ last xs) - in case match left_over_vector str [] of - Nothing -> (command, Just fusion_result, Nothing) - Just n -> (command, Just fusion_result, Just n) - ------------------------------------------------------------------------- - --- Fusion happened -fusion_regex = compile "(\\d+).*streamU/unstreamU" [] - --- Data.Array.Vector.Strict.Prim.UVec --- UVectors were left behind -left_over_vector = compile "Data\\.Array\\.Vector\\.Unlifted\\.UArr\\.UArr|Data\\.Array\\.Vector\\.Base\\.Rebox\\.Box" [] - ------------------------------------------------------------------------- - --- Also, bytestring input/output, since we're strict --- Document that this isn't for interactive - --- --- | readProcess forks an external process, reads its standard output --- strictly, blocking until the process terminates, and returns either the output --- string, or, in the case of non-zero exit status, an error code, and --- any output. --- --- Output is returned strictly, so this is not suitable for --- interactive applications. --- --- Users of this library should compile with -threaded if they --- want other Haskell threads to keep running while waiting on --- the result of readProcess. --- --- > > readProcess "date" [] [] --- > Right "Thu Feb 7 10:03:39 PST 2008\n" --- --- The argumenst are: --- --- * The command to run, which must be in the $PATH, or an absolute path --- --- * A list of separate command line arguments to the program --- --- * A string to pass on the standard input to the program. --- -readProcess :: FilePath -- ^ command to run - -> [String] -- ^ any arguments - -> String -- ^ standard input - -> IO (Either (ExitCode,String) String) -- ^ either the stdout, or an exitcode and any output - -readProcess cmd args input = C.handle (return . handler) $ do - (inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing - output <- hGetContents outh - outMVar <- newEmptyMVar - forkIO $ (C.evaluate (length output) >> putMVar outMVar ()) - when (not (null input)) $ hPutStr inh input - takeMVar outMVar - ex <- C.catch (waitForProcess pid) (\_e -> return ExitSuccess) - hClose outh - hClose inh -- done with stdin - hClose errh -- ignore stderr - - return $ case ex of - ExitSuccess -> Right output - ExitFailure _ -> Left (ex, output) - - where - handler (C.ExitException e) = Left (e,"") - handler e = Left (ExitFailure 1, show e) diff --git a/tests/Examples/fuse.hs b/tests/Examples/fuse.hs deleted file mode 100644 --- a/tests/Examples/fuse.hs +++ /dev/null @@ -1,18 +0,0 @@ -import Data.Array.Vector -import Data.Char -import Data.Bits - -main = do-- print . toList . mapU (^(2::Int)) $ replicateU 100 (1::Int) -- enumFromToU 1 100 - -- print . sumU . mapU (^(2::Int)) $ replicateU 100 (1::Int) -- enumFromToU 1 100 - - -- print . sumU . mapU (^(2::Int)) . replicateU 100000000 $ (1::Int) - - -- print . sum . map f . replicate (100000000::Int) $ (8 :: Int) - print . sumU . mapU f . replicateU (100000000::Int) $ (8 :: Int) - - -- print . nullU . mapU f . enumFromToU 1 $ 100000000 - - -- print . sumU . (\e -> consU 0xdeadbeef e) . replicateU (100000000::Int) $ (8::Int) - -f x = x ^ (2::Int) - diff --git a/tests/Examples/prod.hs b/tests/Examples/prod.hs deleted file mode 100644 --- a/tests/Examples/prod.hs +++ /dev/null @@ -1,33 +0,0 @@ - -{- -main = do putStrLn (show (stupid_mul 100)) - putStrLn "100 multiplications done" - -stupid_mul 0 = [] -stupid_mul it = (s_mul it) : stupid_mul (it-1) -- without "it" after s_mul only one multiplication is executed -s_mul it = mul (replicate 4000 [0..3999]) (replicate 4000 2) - -mul :: [[Double]] -> [Double] -> [Double] -mul [] _ = [] -mul (b:bs) c | sp==0 = sp : (mul bs c) -- always false, force evaluation - - | otherwise = (mul bs c) - - where sp = (scalar b c) - -scalar :: [Double] -> [Double] -> Double -scalar _ [] = 0 -scalar [] _ = 0 -scalar (v:vs) (w:ws) = (v*w) + (scalar vs ws) --} - -import Data.Array.Vector - -n :: Int -n = 4000 - -main = print (sumU (zipWithU (*) a b)) - where - a = replicateU n (2::Double) - b = mapU (realToFrac::Int->Double) $ enumFromToU 0 (n-1) - diff --git a/tests/Examples/raw.hs b/tests/Examples/raw.hs deleted file mode 100644 --- a/tests/Examples/raw.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# OPTIONS -O2 -optc-O -fbang-patterns -fglasgow-exts -optc-march=pentium4 #-} --- --- The Computer Language Shootout --- http://shootout.alioth.debian.org/ --- --- Contributed by Don Stewart --- nsieve over an ST monad Bool array --- - -import Control.Monad.ST ---import Data.Array.ST ---import Data.Array.Base -import System -import Control.Monad -import Data.Bits -import Text.Printf -import Data.Array.Vector.ST - -import GHC.ST - -main = do - n <- getArgs >>= readIO . head :: IO Int - mapM_ (\i -> sieve (10000 `shiftL` (n-i))) [0, 1, 2] - -sieve n = do - let r = runST (do t <- new n True - go t n 2 0) - printf "Primes up to %8d %8d\n" (n::Int) (r::Int) :: IO () - -go !a !m !n !c - | n == m = return c - | otherwise = do - e <- get a n - if e then let loop j - | j < m = do - x <- get a j - when x $ set a j False - loop (j+n) - | otherwise = go a m (n+1) (c+1) - in loop (n `shiftL` 1) - else go a m (n+1) c - diff --git a/tests/Examples/real2Frac.hs b/tests/Examples/real2Frac.hs deleted file mode 100644 --- a/tests/Examples/real2Frac.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# OPTIONS -fglasgow-exts #-} - -import Data.Array.Vector -import Data.Word -import GHC.Prim -import GHC.Base (Int(..)) -import GHC.Float(Double(..),Float(..)) - -n = 40000000 - -main = do - let c = replicateU n (2::Word) - a = mapU fromIntegral (enumFromToU 0 (n-1) ) :: UArr Word - print (sumU (zipWithU (*) c a)) - - -- realToFrac here misses are rule with 6.8.2 diff --git a/tests/Fusion/Test.hs b/tests/Fusion/Test.hs deleted file mode 100644 --- a/tests/Fusion/Test.hs +++ /dev/null @@ -1,202 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ < 610 -import System.Process -import qualified Control.Exception as C -#else -import System.Process hiding (readProcess) -import qualified Control.OldException as C -#endif - -import System.Exit -import System.IO -import Data.List -import Data.Maybe -import System.Directory - -import Control.Monad -import Control.Concurrent -import Text.Printf - -import Text.Regex.PCRE.Light.Char8 - ------------------------------------------------------------------------- - -flags= [["-O","-fspec-constr"] - ,["-O2"] - ] - -tests = - [(Just 2, "cons", flags ) -- expect 2 fusions, with -O2 and -O - ,(Just 2, "snoc", flags ) - ,(Just 2, "empty", flags ) --- ,(Just 1, "from-to", flags ) - ,(Just 2, "singleton", flags ) - ,(Just 4, "map", flags ) - ,(Just 5, "filter", flags ) - ,(Just 2, "replicate", flags ) - ,(Just 2, "takeWhile", flags ) - ,(Just 2, "index", flags ) - ,(Just 3, "null", flags ) - ,(Just 1, "length", flags ) - ,(Just 1, "length-bool", flags ) - ,(Just 1, "length-unit", flags ) - ,(Just 1, "length-char", flags ) - ,(Just 1, "length-word", flags ) - - ,(Just 1, "length-word8", flags ) - ,(Just 1, "length-word16", flags ) - ,(Just 1, "length-word32", flags ) - ,(Just 1, "length-word64", flags ) - - ,(Just 1, "length-int8", flags ) - ,(Just 1, "length-int16", flags ) - ,(Just 1, "length-int32", flags ) - ,(Just 1, "length-int64", flags ) - - ,(Just 1, "length-double", flags ) - ,(Just 1, "length-float", flags ) - ,(Just 2, "head", flags ) - ,(Just 4, "append", flags ) - ,(Just 3, "sum", flags ) - ,(Just 3, "product", flags ) - ,(Just 1, "and", flags ) - ,(Just 1, "or", flags ) - ,(Just 2, "elem", flags ) - ,(Just 2, "tail", flags ) - ,(Just 2, "find", flags ) - ,(Just 2, "findIndex", flags ) - ,(Just 2, "init", flags ) - ,(Just 2, "last", flags ) - ,(Just 3, "foldl1", flags ) - ,(Just 3, "minimum", flags ) - ,(Just 3, "maximum", flags ) - ,(Just 3, "maximumBy", flags ) - ,(Just 3, "minimumBy", flags ) - ,(Just 2, "take", flags ) - ,(Just 2, "drop", flags ) - ,(Just 4, "zipwith", flags ) - ,(Just 4, "zipwith3", flags ) - ,(Just 3, "zip", flags ) -- expect zipU fusion - ,(Just 3, "indexed", flags ) -- failing - ,(Just 1, "unfold", flags ) -- failing - ] - ------------------------------------------------------------------------- - -main = do - printf "Running %d fusion tests.\n" (length tests) - vs <- forM tests $ \x -> do v <- run x - putChar '\n' - return v - printf "\nDone.\n" - if not (and vs) - then exitWith (ExitFailure 1) - else return () - -run :: (Maybe Int, String, [[String]]) -> IO Bool -run (n, name, args) = do - printf "%20s: " name >> hFlush stdout - v <- forM args $ \opt -> do - putChar '.' >> hFlush stdout - (cmd,ex,fusion) <- compile_program name opt - if ex /= n - then do - printf "\n%s failed to trigger fusion. Expected %s, Actual %s.\n" - name (show n) (show ex) - printf "Command line: %s\n" (show $ intercalate " " cmd) - return False - else - if isJust fusion - then do - printf "\n%s failed to remove all vectors.\n" name - printf "Remnants: %s\n" (show fusion) - printf "Command line: %s\n" (show $ intercalate " " cmd) - return False - else return True - return (and v) - ------------------------------------------------------------------------- - -compile_program s opt = do - - let command = [(s ++ ".hs"), "-ddump-simpl","-ddump-simpl-stats","-no-recomp","--make"] ++ opt - x <- readProcess "ghc" command [] - removeFile s - case x of - Left (err,str) -> do - print str - printf "GHC failed to compile %s\n" s - exitWith (ExitFailure 1) -- fatal - - Right str -> do - return $ case match fusion_regex str [] of - Nothing -> (command,Nothing,Nothing) - Just xs -> - let fusion_result = (read $ last xs) - in case match left_over_vector str [] of - Nothing -> (command, Just fusion_result, Nothing) - Just n -> (command, Just fusion_result, Just n) - ------------------------------------------------------------------------- - --- Fusion happened -fusion_regex = compile "(\\d+).*streamU/unstreamU" [] - --- Data.Array.Vector.Strict.Prim.UVec --- UVectors were left behind -left_over_vector = compile "Data\\.Array\\.Vector\\.Unlifted\\.UArr\\.UArr|Data\\.Array\\.Vector\\.Base\\.Rebox\\.Box" [] - ------------------------------------------------------------------------- - --- Also, bytestring input/output, since we're strict --- Document that this isn't for interactive - --- --- | readProcess forks an external process, reads its standard output --- strictly, blocking until the process terminates, and returns either the output --- string, or, in the case of non-zero exit status, an error code, and --- any output. --- --- Output is returned strictly, so this is not suitable for --- interactive applications. --- --- Users of this library should compile with -threaded if they --- want other Haskell threads to keep running while waiting on --- the result of readProcess. --- --- > > readProcess "date" [] [] --- > Right "Thu Feb 7 10:03:39 PST 2008\n" --- --- The argumenst are: --- --- * The command to run, which must be in the $PATH, or an absolute path --- --- * A list of separate command line arguments to the program --- --- * A string to pass on the standard input to the program. --- -readProcess :: FilePath -- ^ command to run - -> [String] -- ^ any arguments - -> String -- ^ standard input - -> IO (Either (ExitCode,String) String) -- ^ either the stdout, or an exitcode and any output - -readProcess cmd args input = C.handle (return . handler) $ do - (inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing - output <- hGetContents outh - outMVar <- newEmptyMVar - forkIO $ (C.evaluate (length output) >> putMVar outMVar ()) - when (not (null input)) $ hPutStr inh input - takeMVar outMVar - ex <- C.catch (waitForProcess pid) (\_e -> return ExitSuccess) - hClose outh - hClose inh -- done with stdin - hClose errh -- ignore stderr - - return $ case ex of - ExitSuccess -> Right output - ExitFailure _ -> Left (ex, output) - - where - handler (C.ExitException e) = Left (e,"") - handler e = Left (ExitFailure 1, show e) diff --git a/tests/Fusion/and.hs b/tests/Fusion/and.hs deleted file mode 100644 --- a/tests/Fusion/and.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print (andU (replicateU 100 True)) - diff --git a/tests/Fusion/append.hs b/tests/Fusion/append.hs deleted file mode 100644 --- a/tests/Fusion/append.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . sumU . mapU (`shiftL` 2) $ - appendU (replicateU 10000000 (1::Int)) - (replicateU 10000000 (7::Int)) diff --git a/tests/Fusion/cons.hs b/tests/Fusion/cons.hs deleted file mode 100644 --- a/tests/Fusion/cons.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print . sumU . consU 0xdeadbeef . replicateU (100000000::Int) $ (8::Int) - diff --git a/tests/Fusion/drop.hs b/tests/Fusion/drop.hs deleted file mode 100644 --- a/tests/Fusion/drop.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . lengthU . dropU 100000 . replicateU 1000000 $ (7 :: Int) - diff --git a/tests/Fusion/elem.hs b/tests/Fusion/elem.hs deleted file mode 100644 --- a/tests/Fusion/elem.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . elemU 100 . mapU (`shiftL` 1) . enumFromToU 1 $ (10000 :: Int) - diff --git a/tests/Fusion/empty.hs b/tests/Fusion/empty.hs deleted file mode 100644 --- a/tests/Fusion/empty.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print . sumU $ consU (0xdeadbeef::Int) emptyU - diff --git a/tests/Fusion/eq.hs b/tests/Fusion/eq.hs deleted file mode 100644 --- a/tests/Fusion/eq.hs +++ /dev/null @@ -1,6 +0,0 @@ - -import Data.Array.Vector -main = print (eqU (replicateU 100000000 True) - (replicateU 100000000 True)) - - diff --git a/tests/Fusion/filter.hs b/tests/Fusion/filter.hs deleted file mode 100644 --- a/tests/Fusion/filter.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . sumU . mapU (`shiftL` 1) . filterU (<20). mapU (*2) . mapU (+1) . replicateU (100000000::Int) $ (8::Int) - diff --git a/tests/Fusion/find.hs b/tests/Fusion/find.hs deleted file mode 100644 --- a/tests/Fusion/find.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . findU (==100) . mapU (`shiftL` 1) . enumFromToU 1 $ (10000 :: Int) - diff --git a/tests/Fusion/findIndex.hs b/tests/Fusion/findIndex.hs deleted file mode 100644 --- a/tests/Fusion/findIndex.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . findIndexU (==100) . mapU (`shiftL` 1) . enumFromToU 1 $ (10000 :: Int) - diff --git a/tests/Fusion/foldl1.hs b/tests/Fusion/foldl1.hs deleted file mode 100644 --- a/tests/Fusion/foldl1.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . foldl1U (+) . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int) - diff --git a/tests/Fusion/from-to.hs b/tests/Fusion/from-to.hs deleted file mode 100644 --- a/tests/Fusion/from-to.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Data.Array.Vector -main = print . head . toList . fromList $ replicate 1 (7::Int) diff --git a/tests/Fusion/head.hs b/tests/Fusion/head.hs deleted file mode 100644 --- a/tests/Fusion/head.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . headU . mapU (`shiftL` 1) . replicateU 1000000000 $ (7 :: Int) - diff --git a/tests/Fusion/index.hs b/tests/Fusion/index.hs deleted file mode 100644 --- a/tests/Fusion/index.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print . (\arr -> arr `indexU` 42) . mapU (subtract 6) . replicateU 10000000 $ (7 :: Int) - diff --git a/tests/Fusion/indexed.hs b/tests/Fusion/indexed.hs deleted file mode 100644 --- a/tests/Fusion/indexed.hs +++ /dev/null @@ -1,7 +0,0 @@ --- only fuses with ghc 6.9 - -import Data.Array.Vector -import Data.Bits - -main = print . sumU . mapU fstS . indexedU . enumFromToU 1 $ (100000000 :: Int) - diff --git a/tests/Fusion/init.hs b/tests/Fusion/init.hs deleted file mode 100644 --- a/tests/Fusion/init.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . lengthU . initU . replicateU 1000000 $ (7 :: Int) - diff --git a/tests/Fusion/last.hs b/tests/Fusion/last.hs deleted file mode 100644 --- a/tests/Fusion/last.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . lastU . mapU (`shiftL` 1) . replicateU 1000000000 $ (7 :: Int) - diff --git a/tests/Fusion/length-bool.hs b/tests/Fusion/length-bool.hs deleted file mode 100644 --- a/tests/Fusion/length-bool.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print (lengthU (replicateU 1 True)) - diff --git a/tests/Fusion/length-char.hs b/tests/Fusion/length-char.hs deleted file mode 100644 --- a/tests/Fusion/length-char.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print (lengthU (replicateU 1 'x')) - diff --git a/tests/Fusion/length-double.hs b/tests/Fusion/length-double.hs deleted file mode 100644 --- a/tests/Fusion/length-double.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print (lengthU (replicateU 1 (pi :: Double))) - diff --git a/tests/Fusion/length-float.hs b/tests/Fusion/length-float.hs deleted file mode 100644 --- a/tests/Fusion/length-float.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print (lengthU (replicateU 1 (pi :: Float))) - diff --git a/tests/Fusion/length-int16.hs b/tests/Fusion/length-int16.hs deleted file mode 100644 --- a/tests/Fusion/length-int16.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Int -main = print (lengthU (replicateU 1 (7 :: Int16))) - diff --git a/tests/Fusion/length-int32.hs b/tests/Fusion/length-int32.hs deleted file mode 100644 --- a/tests/Fusion/length-int32.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Int -main = print (lengthU (replicateU 1 (7 :: Int32))) - diff --git a/tests/Fusion/length-int64.hs b/tests/Fusion/length-int64.hs deleted file mode 100644 --- a/tests/Fusion/length-int64.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Int -main = print (lengthU (replicateU 1 (7 :: Int64))) - diff --git a/tests/Fusion/length-int8.hs b/tests/Fusion/length-int8.hs deleted file mode 100644 --- a/tests/Fusion/length-int8.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Int -main = print (lengthU (replicateU 1 (7 :: Int8))) - diff --git a/tests/Fusion/length-unit.hs b/tests/Fusion/length-unit.hs deleted file mode 100644 --- a/tests/Fusion/length-unit.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print (lengthU (replicateU 1 ())) - diff --git a/tests/Fusion/length-word.hs b/tests/Fusion/length-word.hs deleted file mode 100644 --- a/tests/Fusion/length-word.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Word -main = print (lengthU (replicateU 1 (7 :: Word))) - diff --git a/tests/Fusion/length-word16.hs b/tests/Fusion/length-word16.hs deleted file mode 100644 --- a/tests/Fusion/length-word16.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Word -main = print (lengthU (replicateU 1 (7 :: Word16))) - diff --git a/tests/Fusion/length-word32.hs b/tests/Fusion/length-word32.hs deleted file mode 100644 --- a/tests/Fusion/length-word32.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Word -main = print (lengthU (replicateU 1 (7 :: Word32))) - diff --git a/tests/Fusion/length-word64.hs b/tests/Fusion/length-word64.hs deleted file mode 100644 --- a/tests/Fusion/length-word64.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Word -main = print (lengthU (replicateU 1 (7 :: Word64))) - diff --git a/tests/Fusion/length-word8.hs b/tests/Fusion/length-word8.hs deleted file mode 100644 --- a/tests/Fusion/length-word8.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Word -main = print (lengthU (replicateU 1 (7 :: Word8))) - diff --git a/tests/Fusion/length.hs b/tests/Fusion/length.hs deleted file mode 100644 --- a/tests/Fusion/length.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print . lengthU . enumFromToU 1 $ (100000000 :: Int) - diff --git a/tests/Fusion/lookup.hs b/tests/Fusion/lookup.hs deleted file mode 100644 --- a/tests/Fusion/lookup.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . lookupU 10000 - . zipU (enumFromToU 1 (10000000 :: Int)) $ - (replicateU (10000000 :: Int) (42::Int)) diff --git a/tests/Fusion/map.hs b/tests/Fusion/map.hs deleted file mode 100644 --- a/tests/Fusion/map.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . sumU . mapU (`shiftL` 1) . mapU (*2) . mapU (+1) . replicateU (100000000::Int) $ (8::Int) - diff --git a/tests/Fusion/maximum.hs b/tests/Fusion/maximum.hs deleted file mode 100644 --- a/tests/Fusion/maximum.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . maximumU . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int) - diff --git a/tests/Fusion/maximumBy.hs b/tests/Fusion/maximumBy.hs deleted file mode 100644 --- a/tests/Fusion/maximumBy.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . maximumByU (\x y -> GT) . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int) - diff --git a/tests/Fusion/minimum.hs b/tests/Fusion/minimum.hs deleted file mode 100644 --- a/tests/Fusion/minimum.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . minimumU . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int) - diff --git a/tests/Fusion/minimumBy.hs b/tests/Fusion/minimumBy.hs deleted file mode 100644 --- a/tests/Fusion/minimumBy.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . minimumByU (\x y -> GT) . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int) - diff --git a/tests/Fusion/null-ndp.hs b/tests/Fusion/null-ndp.hs deleted file mode 100644 --- a/tests/Fusion/null-ndp.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -- Parallel.Unlifted -main = print . sumU . mapU fstS . indexedU . enumFromToU 1 $ (100000000 :: Int) - diff --git a/tests/Fusion/null.hs b/tests/Fusion/null.hs deleted file mode 100644 --- a/tests/Fusion/null.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print . nullU . filterU (>10) . mapU (subtract 6) . enumFromToU 1 $ (100000000 :: Int) - diff --git a/tests/Fusion/or.hs b/tests/Fusion/or.hs deleted file mode 100644 --- a/tests/Fusion/or.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print (orU (replicateU 100 True)) - diff --git a/tests/Fusion/product.hs b/tests/Fusion/product.hs deleted file mode 100644 --- a/tests/Fusion/product.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . productU . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int) - diff --git a/tests/Fusion/repeat.hs b/tests/Fusion/repeat.hs deleted file mode 100644 --- a/tests/Fusion/repeat.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . sumU . repeatU 10 $ replicateU (10000000 :: Int) (5::Int) - diff --git a/tests/Fusion/replicate.hs b/tests/Fusion/replicate.hs deleted file mode 100644 --- a/tests/Fusion/replicate.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print . sumU . mapU (subtract 7) . replicateU 10000000 $ (7 :: Int) - diff --git a/tests/Fusion/singleton.hs b/tests/Fusion/singleton.hs deleted file mode 100644 --- a/tests/Fusion/singleton.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print . sumU $ consU (10::Int) (singletonU 2) - diff --git a/tests/Fusion/snoc.hs b/tests/Fusion/snoc.hs deleted file mode 100644 --- a/tests/Fusion/snoc.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Array.Vector -main = print . sumU . (\e -> snocU e 0xdeadbeef) . replicateU (100000000::Int) $ (8::Int) - diff --git a/tests/Fusion/sum-complex.hs b/tests/Fusion/sum-complex.hs deleted file mode 100644 --- a/tests/Fusion/sum-complex.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Data.Array.Vector -import Data.Complex - -main = print . sumU $ replicateU (100000000 :: Int) (1 :+ 1 ::Complex Double) - diff --git a/tests/Fusion/sum-ratio.hs b/tests/Fusion/sum-ratio.hs deleted file mode 100644 --- a/tests/Fusion/sum-ratio.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Data.Array.Vector -import Data.Ratio - -main = print . sumU $ replicateU (100000000 :: Int) (1 % 2 :: Rational) - diff --git a/tests/Fusion/sum.hs b/tests/Fusion/sum.hs deleted file mode 100644 --- a/tests/Fusion/sum.hs +++ /dev/null @@ -1,8 +0,0 @@ -import Data.Array.Vector -import Data.Bits - -main = print . sumU - . mapU (*2) - . mapU (`shiftL` 2) - $ replicateU (100000000 :: Int) (5::Int) - diff --git a/tests/Fusion/tail.hs b/tests/Fusion/tail.hs deleted file mode 100644 --- a/tests/Fusion/tail.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . lengthU . tailU . replicateU 1000000 $ (7 :: Int) - diff --git a/tests/Fusion/take.hs b/tests/Fusion/take.hs deleted file mode 100644 --- a/tests/Fusion/take.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . lengthU . takeU 100000 . replicateU 1000000 $ (7 :: Int) - diff --git a/tests/Fusion/takeWhile.hs b/tests/Fusion/takeWhile.hs deleted file mode 100644 --- a/tests/Fusion/takeWhile.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . sumU . takeWhileU (< (7::Int)). enumFromToU 1 $ 10000000 - - -- replicateU 1000000 $ (7 :: Int) - - -- gets removed entirely! diff --git a/tests/Fusion/unfold.hs b/tests/Fusion/unfold.hs deleted file mode 100644 --- a/tests/Fusion/unfold.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . sumU $ unfoldU 10000 k (0::Int) - where - k b = JustS (b :*: b+1) -- enumFromTo diff --git a/tests/Fusion/zip.hs b/tests/Fusion/zip.hs deleted file mode 100644 --- a/tests/Fusion/zip.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . sumU . mapU fstS $ zipU - (enumFromToU 1 (100000000 :: Int)) - (enumFromToU 2 (100000001 :: Int)) - diff --git a/tests/Fusion/zipwith.hs b/tests/Fusion/zipwith.hs deleted file mode 100644 --- a/tests/Fusion/zipwith.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . sumU . mapU (`shiftL` 1) $ zipWithU (*) - (enumFromToU 1 (100000000 :: Int)) - (replicateU (100000000 :: Int) 42) - diff --git a/tests/Fusion/zipwith3.hs b/tests/Fusion/zipwith3.hs deleted file mode 100644 --- a/tests/Fusion/zipwith3.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Array.Vector -import Data.Bits -main = print . sumU $ zipWith3U (\x y z -> x * y * z) - (enumFromToU 1 (100000000 :: Int)) - (enumFromToU 2 (100000001 :: Int)) - (enumFromToU 7 (100000008 :: Int)) - diff --git a/tests/Makefile b/tests/Makefile deleted file mode 100644 --- a/tests/Makefile +++ /dev/null @@ -1,33 +0,0 @@ -# These should have dependencies on the library too so we don't need to -# force recompilation each time. - -all: hpc fusion - -memcpy_extra: ../cbits/memcpy_extra.c - $(CC) -O3 -c ../cbits/memcpy_extra.c - -FLAGS=-fglasgow-exts -O2 -funbox-strict-fields -fdicts-cheap -fno-method-sharing -fmax-simplifier-iterations10 -fcpr-off -DSAFE -cpp -I../include -hpc: memcpy_extra - rm -f run.tix - ghc ${FLAGS} --make Properties/Test.hs -i.. -fhpc memcpy_extra.o -o run - ./run - hpc markup run --exclude=Properties.Utils --exclude=Properties.Monomorphic.Base --exclude=Properties.Monomorphic.UVector - -fusion: ./Fusion/*.hs ./Examples/*.hs - ( cd Fusion && ghc -O --make Test.hs && ./Test ) - ( cd Examples && ghc -O --make Test.hs && ./Test ) - -clean: - rm -f *.html - find . -name '*~' -exec rm {} \; - find . -name '*.hi' -exec rm {} \; - find . -name '*.o' -exec rm {} \; - find . -name '*.log' -exec rm {} \; - find ../Data -name '*~' -exec rm {} \; - find ../Data -name '*.hi' -exec rm {} \; - find ../Data -name '*.o' -exec rm {} \; - rm -f fuse raw run Performance Fusion/Test Examples/Test - rm -f memcpy_extra.o - rm -f *.tix - rm -rf .hpc - diff --git a/tests/Performance.hs b/tests/Performance.hs deleted file mode 100644 --- a/tests/Performance.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# OPTIONS -O2 -optc-O -fglasgow-exts -optc-march=pentium4 #-} -{-# LANGUAGE BangPatterns #-} - -import Text.Printf -import Control.Exception -import System.CPUTime -import System.IO - -import Control.Monad.ST -import System -import Control.Monad -import Data.Bits -import Text.Printf -import Data.Array.Vector.ST - -import Data.Array.Base -import GHC.Exts -import GHC.ST - ------------------------------------------------------------------------- - -time :: IO t -> IO Double -time a = do - start <- getCPUTime - !v <- a - end <- getCPUTime - let diff = (fromIntegral (end - start)) / (10^12) - return diff - -main = do - putStrLn "Starting..." - mapM_ run - [ ("nsieve-bits", time_nsieve 12) - - ] - putStrLn "Done." - -run (s, a) = do - putStr (s++": ") >> hFlush stdout - t <- a - if t then do putStrLn "Ok." - else do putStrLn "Fail! New code was slower." - exitWith (ExitFailure 1) - ------------------------------------------------------------------------- --- bitwise prime sive - -time_nsieve n = do - !x <- (time (nsieve1 n)) - !y <- (time (nsieve2 n)) - return (x < y) - - where - - ------------------------------------------------------------------------ - -- PROGRAM 1 - - nsieve1 n = mapM_ (\i -> sieve1 (10000 `shiftL` (n-i))) [0, 1, 2] - - sieve1 n = do - let r = runST (do t <- new n True - go t n 2 0) - n `seq` r `seq` return () - - go !a !m !n !c - | n == m = return c - | otherwise = do - e <- get a n - if e then let loop j - | j < m = do - x <- get a j - when x $ set a j False - loop (j+n) - | otherwise = go a m (n+1) (c+1) - in loop (n `shiftL` 1) - else go a m (n+1) c - -{- - {-# INLINE newArrayT #-} - newArrayT n@(I# n#) t = ST $ \s1# -> - case newByteArray# (bOOL_SCALE n#) s1# of { (# s2#, marr# #) -> - case bOOL_WORD_SCALE n# of { n'# -> - let loop i# s3# | i# ==# n'# = s3# - | otherwise = - case writeWordArray# marr# i# e# s3# of { s4# -> - loop (i# +# 1#) s4# } in - case loop 0# s2# of { s3# -> - (# s3#, STUVector n marr# #) }}} - where - W# e# = if t then maxBound else 0 -- True --} - - ------------------------------------------------------------------------ - -- PROGRAM 2 - - nsieve2 n = mapM_ (\i -> sieve2 (10000 `shiftL` (n-i))) [0, 1, 2] - - sieve2 n = do - let r = runST (do a <- newArray (2,n) True :: ST s (STUArray s Int Bool) - go2 a n 2 0) - n `seq` r `seq` return () - - go2 !a !m !n !c - | n == m = return c - | otherwise = do - e <- unsafeRead a n - if e then let loop j - | j < m = do - x <- unsafeRead a j - when x $ unsafeWrite a j False - loop (j+n) - - | otherwise = go2 a m (n+1) (c+1) - in loop (n `shiftL` 1) - else go2 a m (n+1) c - - ------------------------------------------------------------------------- diff --git a/tests/Properties/Monomorphic/Base.hs b/tests/Properties/Monomorphic/Base.hs deleted file mode 100644 --- a/tests/Properties/Monomorphic/Base.hs +++ /dev/null @@ -1,325 +0,0 @@ --- --- The Data.List api --- -module Properties.Monomorphic.Base where - -import Properties.Utils - -import qualified Data.List as Spec - --- * Basic interface -cons :: A -> [A] -> [A] -empty :: [A] -(++) :: [A] -> [A] -> [A] -head :: [A] -> A -last :: [A] -> A -tail :: [A] -> [A] -init :: [A] -> [A] -null :: [A] -> Bool -length :: [A] -> Int - --- * List transformations -map :: (A -> B) -> [A] -> [B] -reverse :: [A] -> [A] -intersperse :: A -> [A] -> [A] -intercalate :: [A] -> [[A]] -> [A] -transpose :: [[A]] -> [[A]] - --- * Reducing lists (folds) -foldl :: (B -> A -> B) -> B -> [A] -> B -foldl' :: (B -> A -> B) -> B -> [A] -> B -foldl1 :: (A -> A -> A) -> [A] -> A -foldl1' :: (A -> A -> A) -> [A] -> A -foldr :: (A -> B -> B) -> B -> [A] -> B -foldr1 :: (A -> A -> A) -> [A] -> A - --- ** Special folds -concat :: [[A]] -> [A] -concatMap :: (A -> [B]) -> [A] -> [B] -and :: [Bool] -> Bool -or :: [Bool] -> Bool -any :: (A -> Bool) -> [A] -> Bool -all :: (A -> Bool) -> [A] -> Bool -sum :: [N] -> N -product :: [N] -> N -maximum :: [OrdA] -> OrdA -minimum :: [OrdA] -> OrdA - --- * Building lists --- ** Scans -scanl :: (A -> B -> A) -> A -> [B] -> [A] -scanl1 :: (A -> A -> A) -> [A] -> [A] -scanr :: (A -> B -> B) -> B -> [A] -> [B] -scanr1 :: (A -> A -> A) -> [A] -> [A] - --- ** Accumulating maps -mapAccumL :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) -mapAccumR :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) - --- ** Infinite lists -iterate :: (A -> A) -> A -> [A] -repeat :: A -> [A] -replicate :: Int -> A -> [A] -cycle :: [A] -> [A] - --- ** Unfolding -unfoldr :: (B -> Maybe (A, B)) -> B -> [A] - --- * Sublists --- ** Extracting sublists -take :: Int -> [A] -> [A] -drop :: Int -> [A] -> [A] -splitAt :: Int -> [A] -> ([A], [A]) -takeWhile :: (A -> Bool) -> [A] -> [A] -dropWhile :: (A -> Bool) -> [A] -> [A] -span :: (A -> Bool) -> [A] -> ([A], [A]) -break :: (A -> Bool) -> [A] -> ([A], [A]) -group :: [A] -> [[A]] -inits :: [A] -> [[A]] -tails :: [A] -> [[A]] - --- * Predicates -isPrefixOf :: [A] -> [A] -> Bool -isSuffixOf :: [A] -> [A] -> Bool -isInfixOf :: [A] -> [A] -> Bool - --- * Searching lists --- ** Searching by equality -elem :: A -> [A] -> Bool -notElem :: A -> [A] -> Bool -lookup :: A -> [(A, B)] -> Maybe B - --- ** Searching with A predicate -find :: (A -> Bool) -> [A] -> Maybe A -filter :: (A -> Bool) -> [A] -> [A] -partition :: (A -> Bool) -> [A] -> ([A], [A]) - --- * Indexing lists -index :: [A] -> Int -> A -elemIndex :: A -> [A] -> Maybe Int -elemIndices :: A -> [A] -> [Int] -findIndex :: (A -> Bool) -> [A] -> Maybe Int -findIndices :: (A -> Bool) -> [A] -> [Int] - --- * Zipping and unzipping lists -zip :: [A] -> [B] -> [(A, B)] -zip3 :: [A] -> [B] -> [C] -> [(A, B, C)] -zip4 :: [A] -> [B] -> [C] -> [D] -> [(A, B, C, D)] -zip5 :: [A] -> [B] -> [C] -> [D] -> [E] -> [(A, B, C, D, E)] -zip6 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [(A, B, C, D, E, F)] -zip7 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [(A, B, C, D, E, F, G)] -zipWith :: (A -> B -> C) -> [A] -> [B] -> [C] -zipWith3 :: (A -> B -> C -> D) -> [A] -> [B] -> [C] -> [D] -zipWith4 :: (A -> B -> C -> D -> E) -> [A] -> [B] -> [C] -> [D] -> [E] -zipWith5 :: (A -> B -> C -> D -> E -> F) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [H] -unzip :: [(A, B)] -> ([A], [B]) -unzip3 :: [(A, B, C)] -> ([A], [B], [C]) -unzip4 :: [(A, B, C, D)] -> ([A], [B], [C], [D]) -unzip5 :: [(A, B, C, D, E)] -> ([A], [B], [C], [D], [E]) -unzip6 :: [(A, B, C, D, E, F)] -> ([A], [B], [C], [D], [E], [F]) -unzip7 :: [(A, B, C, D, E, F, G)] -> ([A], [B], [C], [D], [E], [F], [G]) - --- * Special lists --- ** Functions on strings -lines :: String -> [String] -words :: String -> [String] -unlines :: [String] -> String -unwords :: [String] -> String - --- ** \"Set\" operations -nub :: [A] -> [A] -delete :: A -> [A] -> [A] -(\\) :: [A] -> [A] -> [A] -union :: [A] -> [A] -> [A] -intersect :: [A] -> [A] -> [A] - --- ** Ordered lists -sort :: [OrdA] -> [OrdA] -insert :: OrdA -> [OrdA] -> [OrdA] - --- * Generalized functions --- ** The \"By\" operations --- *** User-supplied equality (replacing an Eq context) -nubBy :: (A -> A -> Bool) -> [A] -> [A] -deleteBy :: (A -> A -> Bool) -> A -> [A] -> [A] -deleteFirstsBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] -unionBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] -intersectBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] -groupBy :: (A -> A -> Bool) -> [A] -> [[A]] - --- *** User-supplied comparison (replacing an Ord context) -sortBy :: (A -> A -> Ordering) -> [A] -> [A] -insertBy :: (A -> A -> Ordering) -> A -> [A] -> [A] -maximumBy :: (A -> A -> Ordering) -> [A] -> A -minimumBy :: (A -> A -> Ordering) -> [A] -> A - --- * The \"generic\" operations -genericLength :: [A] -> I -genericTake :: I -> [A] -> [A] -genericDrop :: I -> [A] -> [A] -genericSplitAt :: I -> [A] -> ([A], [A]) -genericIndex :: [A] -> I -> A -genericReplicate :: I -> A -> [A] - - - --- * Basic interface -cons = (:) -empty = [] -(++) = (Spec.++) -head = Spec.head -last = Spec.last -tail = Spec.tail -init = Spec.init -null = Spec.null -length = Spec.length - --- * List transformations -map = Spec.map -reverse = Spec.reverse -intersperse = Spec.intersperse - --- intercalate = -- Spec.intercalate -intercalate xs xss = Spec.concat (Spec.intersperse xs xss) - -transpose = Spec.transpose - --- * Reducing lists (folds) -foldl = Spec.foldl -foldl' = Spec.foldl' -foldl1 = Spec.foldl1 -foldl1' = Spec.foldl1' -foldr = Spec.foldr -foldr1 = Spec.foldr1 - --- ** Special folds -concat = Spec.concat -concatMap = Spec.concatMap -and = Spec.and -or = Spec.or -any = Spec.any -all = Spec.all -sum = Spec.sum -product = Spec.product -maximum = Spec.maximum -minimum = Spec.minimum - --- * Building lists --- ** Scans -scanl = Spec.scanl -scanl1 = Spec.scanl1 -scanr = Spec.scanr -scanr1 = Spec.scanr1 - --- ** Accumulating maps -mapAccumL = Spec.mapAccumL -mapAccumR = Spec.mapAccumR - --- ** Infinite lists -iterate = Spec.iterate -repeat = Spec.repeat -replicate = Spec.replicate -cycle = Spec.cycle - --- ** Unfolding -unfoldr = Spec.unfoldr - --- * Sublists --- ** Extracting sublists -take = Spec.take -drop = Spec.drop -splitAt = Spec.splitAt -takeWhile = Spec.takeWhile -dropWhile = Spec.dropWhile -span = Spec.span -break = Spec.break -group = Spec.group -inits = Spec.inits -tails = Spec.tails - --- * Predicates -isPrefixOf = Spec.isPrefixOf -isSuffixOf = Spec.isSuffixOf -isInfixOf = Spec.isInfixOf - --- * Searching lists --- ** Searching by equality -elem = Spec.elem -notElem = Spec.notElem -lookup = Spec.lookup - --- ** Searching with a predicate -find = Spec.find -filter = Spec.filter -partition = Spec.partition - --- * Indexing lists -index = (Spec.!!) -elemIndex = Spec.elemIndex -elemIndices = Spec.elemIndices -findIndex = Spec.findIndex -findIndices = Spec.findIndices - --- * Zipping and unzipping lists -zip = Spec.zip -zip3 = Spec.zip3 -zip4 = Spec.zip4 -zip5 = Spec.zip5 -zip6 = Spec.zip6 -zip7 = Spec.zip7 -zipWith = Spec.zipWith -zipWith3 = Spec.zipWith3 -zipWith4 = Spec.zipWith4 -zipWith5 = Spec.zipWith5 -zipWith6 = Spec.zipWith6 -zipWith7 = Spec.zipWith7 -unzip = Spec.unzip -unzip3 = Spec.unzip3 -unzip4 = Spec.unzip4 -unzip5 = Spec.unzip5 -unzip6 = Spec.unzip6 -unzip7 = Spec.unzip7 - --- * Special lists --- ** Functions on strings -lines = Spec.lines -words = Spec.words -unlines = Spec.unlines -unwords = Spec.unwords - --- ** \"Set\" operations -nub = Spec.nub -delete = Spec.delete -(\\) = (Spec.\\) -union = Spec.union -intersect = Spec.intersect - --- ** Ordered lists -sort = Spec.sort -insert = Spec.insert - --- * Generalized functions --- ** The \"By\" operations --- *** User-supplied equality (replacing an Eq context) -nubBy = Spec.nubBy -deleteBy = Spec.deleteBy -deleteFirstsBy = Spec.deleteFirstsBy -unionBy = Spec.unionBy -intersectBy = Spec.intersectBy -groupBy = Spec.groupBy - --- *** User-supplied comparison (replacing an Ord context) -sortBy = Spec.sortBy -insertBy = Spec.insertBy -maximumBy = Spec.maximumBy -minimumBy = Spec.minimumBy - --- * The \"generic\" operations -genericLength = Spec.genericLength -genericTake = Spec.genericTake -genericDrop = Spec.genericDrop -genericSplitAt = Spec.genericSplitAt -genericIndex = Spec.genericIndex -genericReplicate = Spec.genericReplicate diff --git a/tests/Properties/Monomorphic/UVector.hs b/tests/Properties/Monomorphic/UVector.hs deleted file mode 100644 --- a/tests/Properties/Monomorphic/UVector.hs +++ /dev/null @@ -1,391 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module Properties.Monomorphic.UVector where - --- --- just test the List api --- - -import Properties.Utils - -import qualified Data.Array.Vector as List -import Data.Array.Vector (UArr, (:*:), MaybeS) - --- * Basic interface -cons :: A -> UArr A -> UArr A -snoc :: UArr A -> A -> UArr A -empty :: UArr A -singleton :: A -> UArr A -head :: UArr A -> A -length :: UArr A -> Int -append :: UArr A -> UArr A -> UArr A -tail :: UArr A -> UArr A -null :: UArr A -> Bool -init :: UArr A -> UArr A -last :: UArr A -> A - --- * List transformations -map :: (A -> B) -> UArr A -> UArr B - -{- -reverse :: [A] -> [A] -intersperse :: A -> [A] -> [A] -intercalate :: [A] -> [[A]] -> [A] -transpose :: [[A]] -> [[A]] - --- * Reducing lists (folds) --} -foldl :: (B -> A -> B) -> B -> UArr A -> B -foldl1 :: (A -> A -> A) -> UArr A -> A -{- -foldl' :: (B -> A -> B) -> B -> [A] -> B -foldl1' :: (A -> A -> A) -> [A] -> A -foldr :: (A -> B -> B) -> B -> [A] -> B -foldr1 :: (A -> A -> A) -> [A] -> A - --- ** Special folds -concat :: [[A]] -> [A] -concatMap :: (A -> [B]) -> [A] -> [B] --} -and :: UArr Bool -> Bool -or :: UArr Bool -> Bool -any :: (A -> Bool) -> UArr A -> Bool -all :: (A -> Bool) -> UArr A -> Bool -sum :: UArr N -> N -product :: UArr N -> N -maximum :: UArr OrdA -> OrdA -minimum :: UArr OrdA -> OrdA - --- * Building lists --- ** Scans - -scanl :: (A -> B -> A) -> A -> UArr B -> UArr A -scanl1 :: (A -> A -> A) -> UArr A -> UArr A - -{- -scanr :: (A -> B -> B) -> B -> [A] -> [B] -scanr1 :: (A -> A -> A) -> [A] -> [A] --} - --- ** Accumulating maps -{- -mapAccumL :: (C -> A -> (C, B)) -> C -> UArr A -> UArr B -mapAccumR :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) - --- ** Infinite lists -repeat :: A -> [A] --} -iterate :: Int -> (A -> A) -> A -> UArr A - -replicate :: Int -> A -> UArr A -{- -cycle :: [A] -> [A] - --} --- ** Unfolding -unfoldr :: Int -> (B -> MaybeS (A :*: B)) -> B -> UArr A - --- * Sublists --- ** Extracting sublists -take :: Int -> UArr A -> UArr A -drop :: Int -> UArr A -> UArr A -splitAt :: Int -> UArr A -> (UArr A, UArr A) -takeWhile :: (A -> Bool) -> UArr A -> UArr A -dropWhile :: (A -> Bool) -> UArr A -> UArr A -{- -span :: (A -> Bool) -> [A] -> ([A], [A]) -break :: (A -> Bool) -> [A] -> ([A], [A]) -group :: [A] -> [[A]] -inits :: [A] -> [[A]] -tails :: [A] -> [[A]] - --- * Predicates -isPrefixOf :: [A] -> [A] -> Bool -isSuffixOf :: [A] -> [A] -> Bool -isInfixOf :: [A] -> [A] -> Bool - --} - --- * Searching lists --- ** Searching by equality -elem :: A -> UArr A -> Bool -notElem :: A -> UArr A -> Bool -lookup :: A -> UArr (A :*: B) -> Maybe B - --- ** Searching with A predicate -find :: (A -> Bool) -> UArr A -> Maybe A -filter :: (A -> Bool) -> UArr A -> UArr A -{- -partition :: (A -> Bool) -> [A] -> ([A], [A]) --} - --- * Indexing lists -index :: UArr A -> Int -> A -findIndex :: (A -> Bool) -> UArr A -> Maybe Int -{- -elemIndex :: A -> [A] -> Maybe Int -elemIndices :: A -> [A] -> [Int] -findIndices :: (A -> Bool) -> [A] -> [Int] --} - --- * Zipping and unzipping lists -zip :: UArr A -> UArr B -> UArr (A :*: B) -zip3 :: UArr A -> UArr B -> UArr C -> UArr (A :*: B :*: C) - -{- -zip4 :: [A] -> [B] -> [C] -> [D] -> [(A, B, C, D)] -zip5 :: [A] -> [B] -> [C] -> [D] -> [E] -> [(A, B, C, D, E)] -zip6 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [(A, B, C, D, E, F)] -zip7 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [(A, B, C, D, E, F, G)] --} - -zipWith :: (A -> B -> C) -> UArr A -> UArr B -> UArr C -zipWith3 :: (A -> B -> C -> D) -> UArr A -> UArr B -> UArr C -> UArr D - -{- -zipWith4 :: (A -> B -> C -> D -> E) -> [A] -> [B] -> [C] -> [D] -> [E] -zipWith5 :: (A -> B -> C -> D -> E -> F) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [H] --} -unzip :: UArr (A :*: B) -> (UArr A :*: UArr B) -unzip3 :: UArr (A :*: B :*: C) -> (UArr A :*: UArr B :*: UArr C) -{- -unzip4 :: [(A, B, C, D)] -> ([A], [B], [C], [D]) -unzip5 :: [(A, B, C, D, E)] -> ([A], [B], [C], [D], [E]) -unzip6 :: [(A, B, C, D, E, F)] -> ([A], [B], [C], [D], [E], [F]) -unzip7 :: [(A, B, C, D, E, F, G)] -> ([A], [B], [C], [D], [E], [F], [G]) --} - -{- --- * Special lists --- ** Functions on strings -lines :: String -> [String] -words :: String -> [String] -unlines :: [String] -> String -unwords :: [String] -> String - --- ** \"Set\" operations -nub :: [A] -> [A] -delete :: A -> [A] -> [A] -(\\) :: [A] -> [A] -> [A] -union :: [A] -> [A] -> [A] -intersect :: [A] -> [A] -> [A] - --- ** Ordered lists -sort :: [OrdA] -> [OrdA] -insert :: OrdA -> [OrdA] -> [OrdA] - --- * Generalized functions --- ** The \"By\" operations --- *** User-supplied equality (replacing an Eq context) -nubBy :: (A -> A -> Bool) -> [A] -> [A] -deleteBy :: (A -> A -> Bool) -> A -> [A] -> [A] -deleteFirstsBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] -unionBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] -intersectBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] -groupBy :: (A -> A -> Bool) -> [A] -> [[A]] - --- *** User-supplied comparison (replacing an Ord context) -sortBy :: (A -> A -> Ordering) -> [A] -> [A] -insertBy :: (A -> A -> Ordering) -> A -> [A] -> [A] --} -maximumBy :: (A -> A -> Ordering) -> UArr A -> A -minimumBy :: (A -> A -> Ordering) -> UArr A -> A - -{- --- * The \"generic\" operations -genericLength :: [A] -> I -genericTake :: I -> [A] -> [A] -genericDrop :: I -> [A] -> [A] -genericSplitAt :: I -> [A] -> ([A], [A]) -genericIndex :: [A] -> I -> A -genericReplicate :: I -> A -> [A] --} - - --- * Basic interface -cons = List.consU -empty = List.emptyU -snoc = List.snocU -singleton = List.singletonU -head = List.headU -length = List.lengthU -append = List.appendU -tail = List.tailU -null = List.nullU -init = List.initU -last = List.lastU - --- * List transformations -map = List.mapU - -{- -reverse = List.reverse -intersperse = List.intersperse -intercalate = List.intercalate -transpose = List.transpose --} - --- * Reducing lists (folds) -foldl = List.foldlU -foldl1 = List.foldl1U - -{- -foldl' = List.foldl' -foldl1' = List.foldl1' -foldr = List.foldr -foldr1 = List.foldr1 --} - --- ** Special folds -{- -concat = List.concat -concatMap = List.concatMap --} -and = List.andU -or = List.orU -any = List.anyU -all = List.allU -sum = List.sumU -product = List.productU -maximum = List.maximumU -minimum = List.minimumU - --- * Building lists --- ** Scans - -scanl = List.scanlU -scanl1 = List.scanl1U -{- -scanr = List.scanr -scanr1 = List.scanr1 - --- ** Accumulating maps -mapAccumL = List.mapAccumL -mapAccumR = List.mapAccumR - --- ** Infinite lists -repeat = List.repeat --} -iterate = List.iterateU -replicate = List.replicateU -{- -cycle = List.cycle - --} --- ** Unfolding -unfoldr = List.unfoldU - --- * Sublists --- ** Extracting sublists -take = List.takeU -drop = List.dropU -splitAt = List.splitAtU -takeWhile = List.takeWhileU -dropWhile = List.dropWhileU -{- -span = List.span -break = List.break -group = List.group -inits = List.inits -tails = List.tails - --- * Predicates -isPrefixOf = List.isPrefixOf -isSuffixOf = List.isSuffixOf -isInfixOf = List.isInfixOf --} - --- * Searching lists --- ** Searching by equality -elem = List.elemU -notElem = List.notElemU -lookup = List.lookupU - --- ** Searching with a predicate -find = List.findU -filter = List.filterU -{- -partition = List.partition --} - --- * Indexing lists -index = List.indexU -findIndex = List.findIndexU -{- -elemIndex = List.elemIndex -elemIndices = List.elemIndices -findIndices = List.findIndices --} - --- * Zipping and unzipping lists -zip = List.zipU -zip3 = List.zip3U -{- -zip4 = List.zip4 -zip5 = List.zip5 -zip6 = List.zip6 -zip7 = List.zip7 --} -zipWith = List.zipWithU -zipWith3 = List.zipWith3U -{- -zipWith4 = List.zipWith4 -zipWith5 = List.zipWith5 -zipWith6 = List.zipWith6 -zipWith7 = List.zipWith7 --} -unzip = List.unzipU -unzip3 = List.unzip3U -{- -unzip4 = List.unzip4 -unzip5 = List.unzip5 -unzip6 = List.unzip6 -unzip7 = List.unzip7 --} - -{- --- * Special lists --- ** Functions on strings -lines = List.lines -words = List.words -unlines = List.unlines -unwords = List.unwords - --- ** \"Set\" operations -nub = List.nub -delete = List.delete -(\\) = (List.\\) -union = List.union -intersect = List.intersect - --- ** Ordered lists -sort = List.sort -insert = List.insert - --- * Generalized functions --- ** The \"By\" operations --- *** User-supplied equality (replacing an Eq context) -nubBy = List.nubBy -deleteBy = List.deleteBy -deleteFirstsBy = List.deleteFirstsBy -unionBy = List.unionBy -intersectBy = List.intersectBy -groupBy = List.groupBy - --- *** User-supplied comparison (replacing an Ord context) -sortBy = List.sortBy -insertBy = List.insertBy --} -maximumBy = List.maximumByU -minimumBy = List.minimumByU - -{- --- * The \"generic\" operations -genericLength = List.genericLength -genericTake = List.genericTake -genericDrop = List.genericDrop -genericSplitAt = List.genericSplitAt -genericIndex = List.genericIndex -genericReplicate = List.genericReplicate --} diff --git a/tests/Properties/Specific.hs b/tests/Properties/Specific.hs deleted file mode 100644 --- a/tests/Properties/Specific.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeOperators #-} - -module Properties.Specific where - -import Properties.Utils - -import Data.Array.Vector.Stream -import Data.Array.Vector.Prim.Hyperstrict -import Data.Array.Vector - -import Control.Monad.ST - -import Data.Word -import Data.Int -import Data.Complex -import Data.Ratio -import Data.List - -import System.IO -import System.Directory - -import System.IO.Unsafe -import Debug.Trace - -prop_scanResU :: (A -> A -> A) -> A -> UArr A -> Bool -prop_scanResU f x xs = ((\(initU :*: lastU) -> fromU initU ++ [lastU]) $ scanResU f x xs) == scanl f x (fromU xs) - - --- Not dealing with the allocation size parameter for now -prop_replicateEachU :: PosUArr -> UArr A -> Bool -prop_replicateEachU (PosUArr r) e = replicateEachU (sumU r) r e == (toU . concat $ zipWith replicate (fromU r) (fromU e)) - --- FIXME: doesn't check negative numbers -prop_unitsU n = n >= 0 ==> (fromU . unitsU $ n) == replicate n () - -prop_indexedU :: UArr A -> Bool -prop_indexedU xs = indexedU xs == (toU . zipWith (:*:) [0..] . fromU $ xs) - -prop_fstU :: UArr (A :*: B) -> Bool -prop_fstU xs = (fromU . fstU $ xs) == (map fstS . fromU $ xs) - -prop_sndU :: UArr (A :*: B) -> Bool -prop_sndU xs = (fromU . sndU $ xs) == (map sndS . fromU $ xs) - -prop_repeatU :: Int -> UArr A -> Property -prop_repeatU n xs = n > 0 ==> (fromU $ repeatU n xs) == (concat $ replicate n (fromU xs)) - --- FIXME: test for mismatching lengths when it stops crashing the testsuite -prop_packU :: ELUArrs A Bool -> Bool -prop_packU (ELUArrs xs fs) = (fromU $ packU xs fs) == (map fst . filter snd $ zip (fromU xs) (fromU fs)) - -prop_foldl1MaybeU :: (A -> A -> A) -> UArr A -> Bool -prop_foldl1MaybeU f xs = case foldl1MaybeU f xs of - JustS a -> a == foldl1 f (fromU xs) - _ -> nullU xs --- FIXME: DRY -prop_fold1MaybeU :: (A -> A -> A) -> UArr A -> Bool -prop_fold1MaybeU f xs = case fold1MaybeU f xs of - JustS a -> a == foldl1 f (fromU xs) - _ -> nullU xs - -prop_scanU :: (A -> A -> A) -> A -> UArr A -> Bool -prop_scanU f x xs = (fromU $ scanU f x xs) == (init $ scanl f x (fromU xs)) - --- FIXME: test for empty input exception -prop_scan1U :: (A -> A -> A) -> UArr A -> Property -prop_scan1U f xs = (not . nullU $ xs) ==> - (fromU $ scan1U f xs) == (scanl1 f (fromU xs)) - -prop_mapAccumLU :: (C -> A -> C :*: B) -> C -> UArr A -> Bool -prop_mapAccumLU f x xs = (fromU $ mapAccumLU f x xs) == (snd $ mapAccumL (\a b -> unpairS $ f a b) x (fromU xs)) - --- FIXME: we want to test cases in which the generating array doesn't satisfy --- our conditions, too. -prop_combineU :: (CombineGen A) -> Property -prop_combineU (CombineGen f xs ys) = (lengthU $ filterU id f) == lengthU xs - && (lengthU $ filterU not f) == lengthU ys ==> - (fromU $ combineU f xs ys) == (reverse . snd $ foldl (\((xs, ys), acc) a -> if a then ((tail xs, ys), (head xs):acc) else ((xs, tail ys), (head ys):acc)) ((fromU xs, fromU ys), []) (fromU f)) - ------------------------------------------------------------------------- --- *** Enumerated array generators - -prop_enumFromToU :: Int -> Int -> Bool -prop_enumFromToU start end = (fromU $ enumFromToU start end) == [start..end] - --- FIXME: not checking when end > start or if either is negative (those should all throw exceptions probably) -prop_enumFromToFracU :: Double -> Double -> Property -prop_enumFromToFracU start end = start <= end ==> (property $ (fromU $ enumFromToFracU start end) == [start..end]) - -prop_enumFromThenToU :: Int -> Int -> Int -> Property -prop_enumFromThenToU start next end = next /= start ==> (property $ (fromU $ enumFromThenToU start next end) == [start,next..end]) - --- FIXME: not checking the length for now -prop_enumFromStepLenU :: Int -> Int -> Int -> Property -prop_enumFromStepLenU start step len = len >= 0 ==> (property $ (fromU $ enumFromStepLenU start step len) == (take len $ [start, (start + step)..])) - --- FIXME: not checking the length for now -prop_enumFromToEachU :: UArr (Int :*: Int) -> Bool -prop_enumFromToEachU reps = (fromU $ enumFromToEachU (sumU . mapU (\(x :*: y) -> max (y - x + 1) 0) $ reps) reps) == (concatMap (\(x :*: y) -> [x..y]) . fromU $ reps) - ------------------------------------------------------------------------- --- *** Representation-specific operations - --- These aren't very good tests... -prop_lengthU :: (UA a, Show a) => UArr a -> Bool -prop_lengthU xs = lengthU xs == (length . fromU $ xs) - -prop_indexU :: (UA a, Eq a, Show a) => UArr a -> Int -> Property -prop_indexU xs i = i >= 0 && i < lengthU xs ==> - xs `indexU` i == ((!! i) . fromU $ xs) - --- FIXME: check for bounds issues rather than excluding them -prop_sliceU :: (UA a, Eq a, Show a) => BoundedIndex a -> Int -> Property -prop_sliceU (BoundedIndex u start) len = len >= 0 && start >= 0 && lengthU u > 0 ==> - (fromU $ sliceU u start len) == (take len . drop start . fromU $ u) - -prop_newMU_copyMU_lengthMU :: (UA a, Show a) => UArr a -> Bool -prop_newMU_copyMU_lengthMU xs = runST (do let len = lengthU xs - mu <- newMU len - copyMU mu 0 xs - return $ lengthMU mu == len) - -prop_readMU :: (UA a, Eq a, Show a) => UArr a -> Int -> Property -prop_readMU xs i = i >= 0 && i < lengthU xs ==> - runST (do let len = lengthU xs - mu <- newMU len - copyMU mu 0 xs - x <- readMU mu i - return $ x == xs `indexU` i) - -prop_writeMU :: (UA a, Eq a, Show a) => UArr a -> Int -> a -> Property -prop_writeMU xs i e = i >= 0 && i < lengthU xs ==> - runST (do let len = lengthU xs - mu <- newMU len - copyMU mu 0 xs - writeMU mu i e - x <- readMU mu i - return $ x == e) - -prop_unsafeFreezeMU :: (UA a, Eq a, Show a) => UArr a -> Int -> Property -prop_unsafeFreezeMU xs len = len >= 0 && len < lengthU xs ==> - runST (do let l = lengthU xs - mu <- newMU l - copyMU mu 0 xs - unsafeFreezeMU mu len) == takeU len xs - -prop_hPutU_hGetU :: (UIO a, Eq a, Show a) => UArr a -> Bool -prop_hPutU_hGetU xs = unsafePerformIO $ - do tmp <- getTemporaryDirectory - (path, h) <- openTempFile tmp "uvector_test" - hPutU h xs - hSeek h AbsoluteSeek 0 - ys <- hGetU h - hClose h - removeFile path - return $ xs == ys - -prop_memcpyMU :: (UA a, Eq a, Show a) => UArr a -> Int -> Property -prop_memcpyMU xs len = len >= 0 && len < lengthU xs ==> takeU len frozen == takeU len xs - where frozen = runST (do mu <- newMU $ lengthU xs - mu1 <- newMU $ lengthU xs - copyMU mu 0 xs - memcpyMU mu mu1 len - unsafeFreezeAllMU mu1) - -prop_memcpyOffMU :: (UA a, Eq a, Show a) => Ind2LenUArr a -> Property -prop_memcpyOffMU (Ind2LenUArr xs startxs startys len) = - len >= 0 && startxs + len < lengthU xs && startys + len < lengthU xs && - startxs >= 0 && startys >= 0 ==> - sliceU xs startxs len == sliceU frozen startys len - where frozen = runST (do mu <- newMU $ lengthU xs - mu1 <- newMU $ lengthU xs - copyMU mu 0 xs - memcpyOffMU mu mu1 startxs startys len - unsafeFreezeAllMU mu1) - -prop_memmoveOffMU :: (UA a, Eq a, Show a) => Ind2LenUArr a -> Property -prop_memmoveOffMU (Ind2LenUArr xs startxs startys len) = - len >= 0 && startxs + len < lengthU xs && startys + len < lengthU xs && - startxs >= 0 && startys >= 0 ==> - sliceU xs startxs len == sliceU frozen startys len - where frozen = runST (do mu <- newMU $ lengthU xs - copyMU mu 0 xs - memmoveOffMU mu mu startxs startys len - unsafeFreezeAllMU mu) - ------------------------------------------------------------- - -prop_unsafeFreezeAllMU :: UArr A -> Bool -prop_unsafeFreezeAllMU xs = - runST (do mu <- newMU $ lengthU xs - copyMU mu 0 xs - unsafeFreezeAllMU mu) == xs - -prop_newU :: UArr A -> Bool -prop_newU a = newU (lengthU a) (\a' -> copyMU a' 0 a) == a - ------------------------------------------------------------------------------- - --- these are a bit silly, but I'm aiming for 100% coverage - -prop_fstS :: A -> B -> Bool -prop_fstS a b = fstS (a :*: b) == a - -prop_sndS :: A -> B -> Bool -prop_sndS a b = sndS (a :*: b) == b - -prop_pairS :: A -> B -> Bool -prop_pairS a b = pairS (a, b) == (a :*: b) - -prop_unpairS :: A -> B -> Bool -prop_unpairS a b = unpairS (a :*: b) == (a, b) - -prop_curryS :: (A :*: B -> C) -> A -> B -> Bool -prop_curryS f a b = curryS f a b == f (a :*: b) - -prop_uncurryS :: (A -> B -> C) -> A -> B -> Bool -prop_uncurryS f a b = uncurryS f (a :*: b) == f a b - -prop_unsafePairS :: A -> B -> Bool -prop_unsafePairS a b = unsafe_pairS (a, b) == (a :*: b) - -prop_unsafeUnpairS :: A -> B -> Bool -prop_unsafeUnpairS a b = unsafe_unpairS (a :*: b) == (a, b) - -prop_maybeS :: B -> (A -> B) -> MaybeS A -> Bool -prop_maybeS b f m@(JustS a) = maybeS b f m == f a -prop_maybeS b f m = maybeS b f m == b - -prop_fromMaybeS :: A -> MaybeS A -> Bool -prop_fromMaybeS x m@(JustS a) = fromMaybeS x m == a -prop_fromMaybeS x m = fromMaybeS x m == x - -prop_functorMaybeS :: (A -> MaybeS A) -> MaybeS A -> Bool -prop_functorMaybeS f m@(JustS a) = fmap f m == JustS (f a) -prop_functorMaybeS f m = fmap f m == NothingS - ------------------------------------------------------------------------------- - -prop_show_read :: UArr A -> Bool -prop_show_read xs = (read . show $ xs) == xs - ------------------------------------------------------------------------------- - -prop_unsafeZipMU :: ELUArrs A A -> Bool -prop_unsafeZipMU (ELUArrs a b) = fstU prod == a && sndU prod == b - where prod = runST (do let aLen = lengthU a - let bLen = lengthU b - aMU <- newMU aLen - bMU <- newMU bLen - copyMU aMU 0 a - copyMU bMU 0 b - unsafeFreezeAllMU $ unsafeZipMU aMU bMU) - -prop_unsafeUnzipMU :: UArr (A :*: B) -> Bool -prop_unsafeUnzipMU xs = fstU xs == x && sndU xs == y - where x = runST (do let len = lengthU xs - mu <- newMU len - copyMU mu 0 xs - (\(x :*: y) -> unsafeFreezeAllMU x) $ unsafeUnzipMU mu) - y = runST (do let len = lengthU xs - mu <- newMU len - copyMU mu 0 xs - (\(x :*: y) -> unsafeFreezeAllMU y) $ unsafeUnzipMU mu) diff --git a/tests/Properties/Test.hs b/tests/Properties/Test.hs deleted file mode 100644 --- a/tests/Properties/Test.hs +++ /dev/null @@ -1,813 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeOperators #-} - --- --- Must have rules off, otherwise the fusion rules will replace the rhs --- with the lhs, and we only end up testing lhs == lhs --- - -import System.IO -import System.Environment -import Properties.Utils -import Debug.Trace - -import qualified Data.Array.Vector as Test -import qualified Properties.Monomorphic.UVector as Test -- stream functions -import qualified Properties.Monomorphic.Base as Spec -- Data.List - -import Data.Array.Vector.Stream -import Data.Array.Vector.Prim.Hyperstrict -import Data.Array.Vector - -import Properties.Specific - -import Data.Word -import Data.Int -import Data.Complex -import Data.Ratio - --- --- Data.Stream <=> Data.List --- - ------------------------------------------------------------------------- --- * Basic interface - -prop_cons = Test.cons `eq2` (Spec.cons) -prop_snoc = Test.snoc `eq2` (\xs x -> xs Spec.++ [x]) -prop_empty = Test.empty `eq0` (Spec.empty) -prop_singleton = Test.singleton `eq1` (\x -> Spec.cons x []) -prop_head = Test.head `eqnotnull1` Spec.head -prop_append = Test.append `eq2` (Spec.++) -prop_tail = Test.tail `eqnotnull1` Spec.tail -prop_null = Test.null `eq1` Spec.null -prop_init = Test.init `eqnotnull1` Spec.init -prop_last = Test.last `eqnotnull1` Spec.last -prop_length = Test.length `eq1` Spec.length - ------------------------------------------------------------------------- --- * List transformations - -prop_map = Test.map `eq2` Spec.map - -{- --- prop_reverse = Test.reverse `eq1` Spec.reverse -prop_intersperse = Test.intersperse `eq2` Spec.intersperse -prop_intercalate = Test.intercalate `eq2` Spec.intercalate --- prop_transpose = Test.transpose `eq1` Spec.transpose --} - ------------------------------------------------------------------------- --- * Reducing lists (folds) - -prop_foldl = Test.foldl `eq3` Spec.foldl - -prop_foldl1 = Test.foldl1 `eqnotnull2` Spec.foldl1 -- n.b. - -{- -prop_foldl' = Test.foldl' `eq3` Spec.foldl' -prop_foldl1' = Test.foldl1' `eqnotnull2` Spec.foldl1' -- n.b. - -prop_foldr = Test.foldr `eq3` Spec.foldr -prop_foldr1 = Test.foldr1 `eqnotnull2` Spec.foldr1 - ------------------------------------------------------------------------- --- ** Special folds - --- prop_concat = Test.concat `eq1` Spec.concat -prop_concatMap = Test.concatMap `eq2` Spec.concatMap --} -prop_and = Test.and `eq1` Spec.and -prop_or = Test.or `eq1` Spec.or -prop_any = Test.any `eq2` Spec.any -prop_all = Test.all `eq2` Spec.all -prop_sum = Test.sum `eq1` Spec.sum -prop_product = Test.product `eq1` Spec.product -prop_maximum = Test.maximum `eqnotnull1` Spec.maximum -prop_minimum = Test.minimum `eqnotnull1` Spec.minimum - ------------------------------------------------------------------------- --- * Building lists --- ** Scans - -prop_scanl = Test.scanl `eq3` (\f x xs -> Spec.init $ Spec.scanl f x xs) -prop_scanl1 = Test.scanl1 `eqnotnull2` Spec.scanl1 - -{- --- prop_scanr = Test.scanr `eq3` Spec.scanr - -{- -prop_scanr1 = Test.scanr1 `eq2` Spec.scanr1 --} - ------------------------------------------------------------------------- --- ** Accumulating maps - -{- -prop_mapAccumL = Test.mapAccumL `eq3` Spec.mapAccumL -prop_mapAccumR = Test.mapAccumR `eq3` Spec.mapAccumR --} - ------------------------------------------------------------------------- --- ** Infinite lists - -prop_iterate = Test.iterate `eqfinite2` Spec.iterate -prop_repeat = Test.repeat `eqfinite1` Spec.repeat --} -prop_iterate = \x -> x >= 0 ==> Test.iterate x `eq2` ((Spec.take x .) . Spec.iterate) -prop_replicate = \x -> x >= 0 ==> Test.replicate x `eq1` Spec.replicate x - -{- -prop_cycle = \x -> not (null x) ==> - (Test.cycle `eqfinite1` Spec.cycle) x --} ------------------------------------------------------------------------- - --- ** Unfolding - -prop_unfoldr = \x -> x >= 0 ==> Test.unfoldr x `eq2` ((Spec.take x .) . Spec.unfoldr) - ------------------------------------------------------------------------- --- * Sublists --- ** Extracting sublists - -prop_take = Test.take `eq2` Spec.take -prop_drop = Test.drop `eq2` Spec.drop -prop_splitAt = Test.splitAt `eq2` Spec.splitAt -prop_takeWhile = Test.takeWhile `eq2` Spec.takeWhile -prop_dropWhile = Test.dropWhile `eq2` Spec.dropWhile - -{- -{- -prop_span = Test.span `eq2` Spec.span -prop_break = Test.break `eq2` Spec.break -prop_group = Test.group `eq1` Spec.group -prop_inits = Test.inits `eq1` Spec.inits -prop_tails = Test.tails `eq1` Spec.tails --} - ------------------------------------------------------------------------- --- * Predicates - -prop_isPrefixOf = Test.isPrefixOf `eq2` Spec.isPrefixOf -{- -prop_isSuffixOf = Test.isSuffixOf `eq2` Spec.isSuffixOf -prop_isInfixOf = Test.isInfixOf `eq2` Spec.isInfixOf --} - ------------------------------------------------------------------------- --- * Searching lists --- ** Searching by equality --} - -prop_elem = Test.elem `eq2` Spec.elem -prop_notElem = Test.notElem `eq2` Spec.notElem -- no specific implementation - -prop_lookup a xs= Test.lookup a xs == Spec.lookup a (map unpairS . fromU $ xs) - ------------------------------------------------------------------------- --- ** Searching with a predicate - - -prop_find = Test.find `eq2` Spec.find -prop_filter = Test.filter `eq2` Spec.filter - -{- --- prop_partition = Test.partition `eq2` Spec.partition --} - ------------------------------------------------------------------------- --- * Indexing lists - -prop_index = \xs n -> n >= 0 && n < Test.length xs ==> - (Test.index `eq2` Spec.index) xs n - -prop_findIndex = Test.findIndex `eq2` Spec.findIndex -{- -prop_elemIndex = Test.elemIndex `eq2` Spec.elemIndex -prop_elemIndices = Test.elemIndices `eq2` Spec.elemIndices -prop_findIndices = Test.findIndices `eq2` Spec.findIndices --} - ------------------------------------------------------------------------- --- * Zipping and unzipping lists - --- To not be this ugly, we would need to define a NatTrans instance for UArr to [], --- which requires a Functor instance on UArr, which seems currently impossible --- due to the UA restriction on the UArr elements. RFunctor could work, but we'd --- need to rewire quickcheck to use that, so this is probably easier. --- -prop_zip (ELUArrs a b) = (map unpairS . fromU $ Test.zip a b) == Spec.zip (fromU a) (fromU b) -prop_zip3 (ELUArrs3 a b c) = (map (\(x :*: y :*: z) -> (x, y, z)) . fromU $ Test.zip3 a b c) == Spec.zip3 (fromU a) (fromU b) (fromU c) - -prop_zipWith f (ELUArrs a b) = (fromU $ Test.zipWith f a b) == Spec.zipWith f (fromU a) (fromU b) -prop_zipWith3 f (ELUArrs3 a b c) = (fromU $ Test.zipWith3 f a b c) == Spec.zipWith3 f (fromU a) (fromU b) (fromU c) - -{- -prop_zip4 = Test.zip4 `eq4` Spec.zip4 -prop_zip5 = Test.zip5 `eq5` Spec.zip5 -prop_zip6 = Test.zip6 `eq6` Spec.zip6 -prop_zip7 = Test.zip7 `eq7` Spec.zip7 -prop_zipWith4 = Test.zipWith4 `eq5` Spec.zipWith4 -prop_zipWith5 = Test.zipWith5 `eq6` Spec.zipWith5 -prop_zipWith6 = Test.zipWith6 `eq7` Spec.zipWith6 -prop_zipWith7 = Test.zipWith7 `eq8` Spec.zipWith7 --} - ------------------------------------------------------------------------- - -prop_unzip xs = ((\(x :*: y) -> (fromU x, fromU y)) . Test.unzip $ (toU . map pairS $ xs)) == Spec.unzip xs -prop_unzip3 xs = ((\(x :*: y :*: z) -> (fromU x, fromU y, fromU z)) . Test.unzip3 $ (toU . map (\(x, y, z) -> (x :*: y :*: z)) $ xs)) == Spec.unzip3 xs - -{- -prop_unzip4 = Test.unzip4 `eq1` Spec.unzip4 -prop_unzip5 = Test.unzip5 `eq1` Spec.unzip5 -prop_unzip6 = Test.unzip6 `eq1` Spec.unzip6 -prop_unzip7 = Test.unzip7 `eq1` Spec.unzip7 --} - ------------------------------------------------------------------------- --- * Special lists --- ** Functions on strings --- prop_unlines = Test.unlines `eq1` Spec.unlines --- prop_lines = Test.lines `eq1` Spec.lines - -{- -prop_words = Test.words `eq1` Spec.words -prop_unwords = Test.unwords `eq1` Spec.unwords --} - ------------------------------------------------------------------------- --- ** \"Set\" operations - -{- -prop_nub = Test.nub `eq1` Spec.nub -prop_delete = Test.delete `eq2` Spec.delete -prop_difference = (Test.\) `eq2` (Spec.\) -prop_union = Test.union `eq2` Spec.union -prop_intersect = Test.intersect `eq2` Spec.intersect --} - ------------------------------------------------------------------------- --- ** Ordered lists - -{- -prop_sort = Test.sort `eq1` Spec.sort -prop_insert = Test.insert `eq2` Spec.insert --} - ------------------------------------------------------------------------- --- * Generalized functions --- ** The \"By\" operations --- *** User-supplied equality (replacing an Eq context) - -{- -prop_nubBy = Test.nubBy `eq2` Spec.nubBy -prop_deleteBy = Test.deleteBy `eq3` Spec.deleteBy -prop_deleteFirstsBy = Test.deleteFirstsBy `eq3` Spec.deleteFirstsBy -prop_unionBy = Test.unionBy `eq3` Spec.unionBy -prop_intersectBy = Test.intersectBy `eq3` Spec.intersectBy -prop_groupBy = Test.groupBy `eq2` Spec.groupBy --} - ------------------------------------------------------------------------- --- *** User-supplied comparison (replacing an Ord context) - -{- -prop_sortBy = Test.sortBy `eq2` Spec.sortBy --} -{- -prop_insertBy = Test.insertBy `eq3` Spec.insertBy --} - - -prop_maximumBy = Test.maximumBy `eqnotnull2` Spec.maximumBy -prop_minimumBy = Test.minimumBy `eqnotnull2` Spec.minimumBy - -{- ------------------------------------------------------------------------- --- * The \"generic\" operations - -prop_genericLength = Test.genericLength `eq1` Spec.genericLength -prop_genericTake = \i -> i >= I 0 ==> - (Test.genericTake `eq2` Spec.genericTake) i -prop_genericDrop = \i -> i >= I 0 ==> - (Test.genericDrop `eq2` Spec.genericDrop) i -prop_genericIndex = \xs i -> i >= I 0 && i < Spec.genericLength xs ==> - (Test.genericIndex `eq2` Spec.genericIndex) xs i -prop_genericSplitAt = \i -> i >= I 0 ==> - (Test.genericSplitAt `eq2` Spec.genericSplitAt) i -prop_genericReplicate = \i -> i >= I 0 ==> - (Test.genericReplicate `eq2` Spec.genericReplicate) i --} - ------------------------------------------------------------------------- - - -main = do - x <- getArgs - let opts' = case x of - [n] -> opts { no_of_tests = read n } - _ -> opts - - hSetBuffering stdout NoBuffering - putStrLn "Testing: Data.Array.Vector <=> Data.List" - putStrLn "==================================\n" - - runTests "Extras" opts' - [-- run prop_repeatU_model - ] - - runTests "Basic interface" opts' - [run prop_cons - ,run prop_snoc - ,run prop_empty - ,run prop_singleton - ,run prop_head - ,run prop_append - ,run prop_tail - ,run prop_null - ,run prop_init - ,run prop_last - ,run prop_length - ] - - runTests "Array transformations" opts' - [run prop_map - {- --- ,run prop_reverse - ,run prop_intersperse - ,run prop_intercalate --- ,run prop_transpose --} - ] - - runTests "Reducing arrays (folds)" opts' - [run prop_foldl --- ,run prop_foldr - - ,run prop_foldl1 --- ,run prop_foldl' --- ,run prop_foldl1' --- ,run prop_foldr1 - ,run prop_foldl1MaybeU - ,run prop_fold1MaybeU - ,run prop_mapAccumLU - ] - - runTests "Special folds" opts' - [ --- run prop_concat, --- run prop_concatMap - run prop_and - ,run prop_or - ,run prop_any - ,run prop_all - ,run prop_sum - ,run prop_product - ,run prop_maximum - ,run prop_minimum - ] - - runTests "Scans" opts' - [run prop_scanl - ,run prop_scanl1 - ,run prop_scanResU - ,run prop_scanU - ,run prop_scan1U --- ,run prop_scanr --- ,run prop_scanr1 - ] - -{- - runTests "Accumulating maps" opts' - [run prop_mapAccumL - ,run prop_mapAccumR - ] --} - - runTests "Generating arrays" opts' - [run prop_iterate - ,run prop_repeatU - ,run prop_replicate - ,run prop_replicateEachU - ,run prop_unitsU - ,run prop_packU - ,run prop_combineU - -- ,run prop_cycle - ] - - - runTests "Unfolding" opts' - [run prop_unfoldr - ] - - - runTests "Extracting subarrays" opts' - [run prop_take - ,run prop_drop - ,run prop_splitAt - ,run prop_takeWhile - ,run prop_dropWhile --- ,run prop_span --- ,run prop_break --- ,run prop_group --- ,run prop_inits --- ,run prop_tails - ] - -{- - runTests "Predicates" opts' - [run prop_isPrefixOf - ,run prop_isSuffixOf - ,run prop_isInfixOf - ] --} - - runTests "Searching by equality" opts' - [run prop_elem - ,run prop_notElem-- no specific implementation - ,run prop_lookup - ] - - runTests "Searching by a predicate" opts' - [run prop_filter - ,run prop_find --- ,run prop_partition - ] - - runTests "Indexing arrays" opts' - [run prop_index - ,run prop_indexedU - ,run prop_findIndex --- ,run prop_elemIndex --- ,run prop_elemIndices --- ,run prop_findIndices - ] - - runTests "Zipping" opts' - [run prop_zip - ,run prop_zip3 --- ,run prop_zip4 --- ,run prop_zip5 --- ,run prop_zip6 --- ,run prop_zip7 - ,run prop_zipWith - ,run prop_zipWith3 --- ,run prop_zipWith4 --- ,run prop_zipWith5 --- ,run prop_zipWith6 --- ,run prop_zipWith7 - ] - - runTests "Unzipping" opts' - [run prop_fstU - ,run prop_sndU - ,run prop_unzip - ,run prop_unzip3 --- ,run prop_unzip4 --- ,run prop_unzip5 --- ,run prop_unzip6 --- ,run prop_unzip7 - ] - -{- - runTests "Functions on strings" opts' - [run prop_unlines - ,run prop_lines - ,run prop_words - ,run prop_unwords - ] --} - -{- - runTests "\"Set\" operations" opts' - [run prop_nub - ,run prop_delete - ,run prop_difference - ,run prop_union - ,run prop_intersect - ] --} - -{- - runTests "Ordered lists" opts' - [run prop_sort - ,run prop_insert - ] --} - -{- - runTests "Eq style \"By\" operations" opts' - [run prop_nubBy - ,run prop_deleteBy - ,run prop_deleteFirstsBy - ,run prop_unionBy - ,run prop_intersectBy - ,run prop_groupBy - ] --} - - runTests "Ord style \"By\" operations" opts' - [ --- ,run prop_insertBy --- ,run prop_sortBy -- note issue here. - run prop_maximumBy - ,run prop_minimumBy - ] - - runTests "Enumerated arrays" opts' - [run prop_enumFromToU - ,run prop_enumFromToFracU - ,run prop_enumFromThenToU - ,run prop_enumFromStepLenU - ,run prop_enumFromToEachU - ] - - runTests "Mutable arrays" opts' - [run prop_unsafeFreezeAllMU - ,run prop_newU - ,run prop_unsafeZipMU - ,run prop_unsafeUnzipMU - ] - - runTests "Hyperstrict" opts' - [run prop_fstS - ,run prop_sndS - ,run prop_pairS - ,run prop_unpairS - ,run prop_curryS - ,run prop_uncurryS - ,run prop_unsafePairS - ,run prop_unsafeUnpairS - ,run prop_maybeS - ,run prop_fromMaybeS - ,run prop_functorMaybeS - ] - - runTests "Text output" opts' - [run prop_show_read - ] - - -- These are a little overkillish (and should be generated by TH, probably) - - runTests "()-specific" opts' - [run (prop_lengthU :: UArr () -> Bool) - ,run (prop_indexU :: UArr () -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex () -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr () -> Bool) - ,run (prop_readMU :: UArr () -> Int -> Property) - ,run (prop_writeMU :: UArr () -> Int -> () -> Property) - ,run (prop_unsafeFreezeMU :: UArr () -> Int -> Property) - ,run (prop_memcpyMU :: UArr () -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr () -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr () -> Property) - ] - - runTests "(a :*: b)-specific" opts' - [run (prop_lengthU :: UArr (A :*: B) -> Bool) - ,run (prop_indexU :: UArr (A :*: B) -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex (A :*: B) -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr (A :*: B) -> Bool) - ,run (prop_readMU :: UArr (A :*: B) -> Int -> Property) - ,run (prop_writeMU :: UArr (A :*: B) -> Int -> (A :*: B) -> Property) - ,run (prop_unsafeFreezeMU :: UArr (A :*: B) -> Int -> Property) - ,run (prop_memcpyMU :: UArr (A :*: B) -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr (A :*: B) -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr (A :*: B) -> Property) - ] - - runTests "Bool-specific" opts' - [run (prop_lengthU :: UArr Bool -> Bool) - ,run (prop_indexU :: UArr Bool -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Bool -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Bool -> Bool) - ,run (prop_readMU :: UArr Bool -> Int -> Property) - ,run (prop_writeMU :: UArr Bool -> Int -> Bool -> Property) - ,run (prop_unsafeFreezeMU :: UArr Bool -> Int -> Property) - ,run (prop_memcpyMU :: UArr Bool -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Bool -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Bool -> Property) - ,run (prop_hPutU_hGetU :: UArr Bool -> Bool) - ] - - runTests "Char-specific" opts' - [run (prop_lengthU :: UArr Char -> Bool) - ,run (prop_indexU :: UArr Char -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Char -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Char -> Bool) - ,run (prop_readMU :: UArr Char -> Int -> Property) - ,run (prop_writeMU :: UArr Char -> Int -> Char -> Property) - ,run (prop_unsafeFreezeMU :: UArr Char -> Int -> Property) - ,run (prop_memcpyMU :: UArr Char -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Char -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Char -> Property) - ,run (prop_hPutU_hGetU :: UArr Char -> Bool) - ] - - runTests "Int-specific" opts' - [run (prop_lengthU :: UArr Int -> Bool) - ,run (prop_indexU :: UArr Int -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Int -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Int -> Bool) - ,run (prop_readMU :: UArr Int -> Int -> Property) - ,run (prop_writeMU :: UArr Int -> Int -> Int -> Property) - ,run (prop_unsafeFreezeMU :: UArr Int -> Int -> Property) - ,run (prop_memcpyMU :: UArr Int -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Int -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Int -> Property) - ,run (prop_hPutU_hGetU :: UArr Int -> Bool) - ] - - runTests "Word-specific" opts' - [run (prop_lengthU :: UArr Word -> Bool) - ,run (prop_indexU :: UArr Word -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Word -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Word -> Bool) - ,run (prop_readMU :: UArr Word -> Int -> Property) - ,run (prop_writeMU :: UArr Word -> Int -> Word -> Property) - ,run (prop_unsafeFreezeMU :: UArr Word -> Int -> Property) - ,run (prop_memcpyMU :: UArr Word -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Word -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Word -> Property) - ,run (prop_hPutU_hGetU :: UArr Word -> Bool) - ] - - runTests "Float-specific" opts' - [run (prop_lengthU :: UArr Float -> Bool) - ,run (prop_indexU :: UArr Float -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Float -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Float -> Bool) - ,run (prop_readMU :: UArr Float -> Int -> Property) - ,run (prop_writeMU :: UArr Float -> Int -> Float -> Property) - ,run (prop_unsafeFreezeMU :: UArr Float -> Int -> Property) - ,run (prop_memcpyMU :: UArr Float -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Float -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Float -> Property) - ,run (prop_hPutU_hGetU :: UArr Float -> Bool) - ] - - runTests "Double-specific" opts' - [run (prop_lengthU :: UArr Double -> Bool) - ,run (prop_indexU :: UArr Double -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Double -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Double -> Bool) - ,run (prop_readMU :: UArr Double -> Int -> Property) - ,run (prop_writeMU :: UArr Double -> Int -> Double -> Property) - ,run (prop_unsafeFreezeMU :: UArr Double -> Int -> Property) - ,run (prop_memcpyMU :: UArr Double -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Double -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Double -> Property) - ,run (prop_hPutU_hGetU :: UArr Double -> Bool) - ] - - runTests "Word8-specific" opts' - [run (prop_lengthU :: UArr Word8 -> Bool) - ,run (prop_indexU :: UArr Word8 -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Word8 -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Word8 -> Bool) - ,run (prop_readMU :: UArr Word8 -> Int -> Property) - ,run (prop_writeMU :: UArr Word8 -> Int -> Word8 -> Property) - ,run (prop_unsafeFreezeMU :: UArr Word8 -> Int -> Property) - ,run (prop_memcpyMU :: UArr Word8 -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Word8 -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Word8 -> Property) - ,run (prop_hPutU_hGetU :: UArr Word8 -> Bool) - ] - - runTests "Word16-specific" opts' - [run (prop_lengthU :: UArr Word16 -> Bool) - ,run (prop_indexU :: UArr Word16 -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Word16 -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Word16 -> Bool) - ,run (prop_readMU :: UArr Word16 -> Int -> Property) - ,run (prop_writeMU :: UArr Word16 -> Int -> Word16 -> Property) - ,run (prop_unsafeFreezeMU :: UArr Word16 -> Int -> Property) - ,run (prop_memcpyMU :: UArr Word16 -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Word16 -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Word16 -> Property) - ,run (prop_hPutU_hGetU :: UArr Word16 -> Bool) - ] - - runTests "Word32-specific" opts' - [run (prop_lengthU :: UArr Word32 -> Bool) - ,run (prop_indexU :: UArr Word32 -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Word32 -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Word32 -> Bool) - ,run (prop_readMU :: UArr Word32 -> Int -> Property) - ,run (prop_writeMU :: UArr Word32 -> Int -> Word32 -> Property) - ,run (prop_unsafeFreezeMU :: UArr Word32 -> Int -> Property) - ,run (prop_memcpyMU :: UArr Word32 -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Word32 -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Word32 -> Property) - ,run (prop_hPutU_hGetU :: UArr Word32 -> Bool) - ] - - runTests "Word64-specific" opts' - [run (prop_lengthU :: UArr Word64 -> Bool) - ,run (prop_indexU :: UArr Word64 -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Word64 -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Word64 -> Bool) - ,run (prop_readMU :: UArr Word64 -> Int -> Property) - ,run (prop_writeMU :: UArr Word64 -> Int -> Word64 -> Property) - ,run (prop_unsafeFreezeMU :: UArr Word64 -> Int -> Property) - ,run (prop_memcpyMU :: UArr Word64 -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Word64 -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Word64 -> Property) - ,run (prop_hPutU_hGetU :: UArr Word64 -> Bool) - ] - - runTests "Int8-specific" opts' - [run (prop_lengthU :: UArr Int8 -> Bool) - ,run (prop_indexU :: UArr Int8 -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Int8 -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Int8 -> Bool) - ,run (prop_readMU :: UArr Int8 -> Int -> Property) - ,run (prop_writeMU :: UArr Int8 -> Int -> Int8 -> Property) - ,run (prop_unsafeFreezeMU :: UArr Int8 -> Int -> Property) - ,run (prop_memcpyMU :: UArr Int8 -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Int8 -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Int8 -> Property) - ,run (prop_hPutU_hGetU :: UArr Int8 -> Bool) - ] - - runTests "Int16-specific" opts' - [run (prop_lengthU :: UArr Int16 -> Bool) - ,run (prop_indexU :: UArr Int16 -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Int16 -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Int16 -> Bool) - ,run (prop_readMU :: UArr Int16 -> Int -> Property) - ,run (prop_writeMU :: UArr Int16 -> Int -> Int16 -> Property) - ,run (prop_unsafeFreezeMU :: UArr Int16 -> Int -> Property) - ,run (prop_memcpyMU :: UArr Int16 -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Int16 -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Int16 -> Property) - ,run (prop_hPutU_hGetU :: UArr Int16 -> Bool) - ] - - runTests "Int32-specific" opts' - [run (prop_lengthU :: UArr Int32 -> Bool) - ,run (prop_indexU :: UArr Int32 -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Int32 -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Int32 -> Bool) - ,run (prop_readMU :: UArr Int32 -> Int -> Property) - ,run (prop_writeMU :: UArr Int32 -> Int -> Int32 -> Property) - ,run (prop_unsafeFreezeMU :: UArr Int32 -> Int -> Property) - ,run (prop_memcpyMU :: UArr Int32 -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Int32 -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Int32 -> Property) - ,run (prop_hPutU_hGetU :: UArr Int32 -> Bool) - ] - - runTests "Int64-specific" opts' - [run (prop_lengthU :: UArr Int64 -> Bool) - ,run (prop_indexU :: UArr Int64 -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex Int64 -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr Int64 -> Bool) - ,run (prop_readMU :: UArr Int64 -> Int -> Property) - ,run (prop_writeMU :: UArr Int64 -> Int -> Int64 -> Property) - ,run (prop_unsafeFreezeMU :: UArr Int64 -> Int -> Property) - ,run (prop_memcpyMU :: UArr Int64 -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr Int64 -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr Int64 -> Property) - ,run (prop_hPutU_hGetU :: UArr Int64 -> Bool) - ] - - runTests "Complex-specific" opts' - [run (prop_lengthU :: UArr (Complex Double) -> Bool) - ,run (prop_indexU :: UArr (Complex Double) -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex (Complex Double) -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr (Complex Double) -> Bool) - ,run (prop_readMU :: UArr (Complex Double) -> Int -> Property) - ,run (prop_writeMU :: UArr (Complex Double) -> Int -> (Complex Double) -> Property) - ,run (prop_unsafeFreezeMU :: UArr (Complex Double) -> Int -> Property) - ,run (prop_memcpyMU :: UArr (Complex Double) -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr (Complex Double) -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr (Complex Double) -> Property) - --,run (prop_hPutU_hGetU :: UArr (Complex Float) -> Bool) - ] - - runTests "Ratio-specific" opts' - [run (prop_lengthU :: UArr (Ratio Int) -> Bool) - ,run (prop_indexU :: UArr (Ratio Int) -> Int -> Property) - ,run (prop_sliceU :: BoundedIndex (Ratio Int) -> Int -> Property) - ,run (prop_newMU_copyMU_lengthMU :: UArr (Ratio Int) -> Bool) - ,run (prop_readMU :: UArr (Ratio Int) -> Int -> Property) - ,run (prop_writeMU :: UArr (Ratio Int) -> Int -> (Ratio Int) -> Property) - ,run (prop_unsafeFreezeMU :: UArr (Ratio Int) -> Int -> Property) - ,run (prop_memcpyMU :: UArr (Ratio Int) -> Int -> Property) - ,run (prop_memcpyOffMU :: Ind2LenUArr (Ratio Int) -> Property) - ,run (prop_memmoveOffMU :: Ind2LenUArr (Ratio Int) -> Property) - --,run (prop_hPutU_hGetU :: UArr (Ratio Int) -> Bool) - ] -{- - runTests "The \"generic\" operations" opts' - [run prop_genericLength - ,run prop_genericTake - ,run prop_genericDrop - ,run prop_genericIndex - ,run prop_genericSplitAt - ,run prop_genericReplicate - ] --} diff --git a/tests/Properties/Utils.hs b/tests/Properties/Utils.hs deleted file mode 100644 --- a/tests/Properties/Utils.hs +++ /dev/null @@ -1,330 +0,0 @@ -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE IncoherentInstances #-} - -module Properties.Utils ( - module Properties.Utils, - module Test.QuickCheck, - module Test.QuickCheck.Batch, - ) where - -import Test.QuickCheck -import Test.QuickCheck.Batch -import Text.Show.Functions -import Control.Monad.Instances - -import Control.Monad (liftM,liftM2,liftM5) - -import qualified Data.Array.Vector as S -import Data.Array.Vector ((:*:)(..)) - -import Data.Word -import Data.Int -import Data.Complex -import Data.Ratio -import Data.List - -opts = TestOptions { - no_of_tests = 500, - length_of_tests = 0, - debug_tests = False - } - -eq0 f g = property $ - model f == g -eq1 f g = \x -> property $ - model (f x) == g (model x) -eq2 f g = \x y -> property $ - model (f x y) == g (model x) (model y) -eq3 f g = \x y z -> property $ - model (f x y z) == g (model x) (model y) (model z) -eq4 f g = \x y z a -> property $ - model (f x y z a) == g (model x) (model y) (model z) (model a) -eq5 f g = \x y z a b -> property $ - model (f x y z a b) == g (model x) (model y) (model z) (model a) (model b) -eq6 f g = \x y z a b c -> property $ - model (f x y z a b c) == g (model x) (model y) (model z) (model a) (model b) (model c) -eq7 f g = \x y z a b c d -> property $ - model (f x y z a b c d) == g (model x) (model y) (model z) (model a) (model b) (model c) (model d) -eq8 f g = \x y z a b c d e -> property $ - model (f x y z a b c d e) == g (model x) (model y) (model z) (model a) (model b) (model c) (model d) (model e) - -eqnotnull1 f g = \x -> (not (S.nullU x)) ==> eq1 f g x -eqnotnull2 f g = \x y -> (not (S.nullU y)) ==> eq2 f g x y -eqnotnull3 f g = \x y z -> (not (S.nullU z)) ==> eq3 f g x y z - -{- -eqfinite1 f g = \x -> forAll arbitrary $ \n -> Prelude.take n (f x) == Prelude.take n (g x) -eqfinite2 f g = \x y -> forAll arbitrary $ \n -> Prelude.take n (f x y) == Prelude.take n (g x y) -eqfinite3 f g = \x y z -> forAll arbitrary $ \n -> Prelude.take n (f x y z) == Prelude.take n (g x y z) --} - -newtype A = A Int deriving (Eq, Show, Read, Arbitrary, S.UA) -newtype B = B Int deriving (Eq, Show, Read, Arbitrary, S.UA) -newtype C = C Int deriving (Eq, Show, Read, Arbitrary, S.UA) -type D = A -type E = B -type F = C -type G = A -type H = B - -{-} -instance NatTrans S.UArr [] where - eta = S.fromU --} -instance NatTrans S.MaybeS Maybe where - eta (S.JustS a) = Just a - eta S.NothingS = Nothing - -newtype OrdA = OrdA Int deriving (Eq, Ord, Show, Arbitrary, S.UA) - -newtype N = N Int deriving (Eq, Ord, Num, Show, Arbitrary, S.UA) -newtype I = I Int deriving (Eq, Ord, Num, Enum, Real, Integral, Show, Arbitrary, S.UA) - -instance Arbitrary Word where - arbitrary = fmap fromIntegral (arbitrary :: Gen Int) - coarbitrary = undefined - -instance Arbitrary Word8 where - arbitrary = fmap fromIntegral (arbitrary :: Gen Int) - coarbitrary = undefined - -instance Arbitrary Word16 where - arbitrary = fmap fromIntegral (arbitrary :: Gen Int) - coarbitrary = undefined - -instance Arbitrary Word32 where - arbitrary = fmap fromIntegral (arbitrary :: Gen Int) - coarbitrary = undefined - -instance Arbitrary Word64 where - arbitrary = fmap fromIntegral (arbitrary :: Gen Integer) - coarbitrary = undefined - -instance Arbitrary Int8 where - arbitrary = fmap fromIntegral (arbitrary :: Gen Int) - coarbitrary = undefined - -instance Arbitrary Int16 where - arbitrary = fmap fromIntegral (arbitrary :: Gen Int) - coarbitrary = undefined - -instance Arbitrary Int32 where - arbitrary = fmap fromIntegral (arbitrary :: Gen Int) - coarbitrary = undefined - -instance Arbitrary Int64 where - arbitrary = fmap fromIntegral (arbitrary :: Gen Integer) - coarbitrary = undefined - -instance (Arbitrary a, RealFloat a) => Arbitrary (Complex a) where - arbitrary = liftM2 (:+) arbitrary arbitrary - coarbitrary = undefined - -instance (Arbitrary a, Integral a) => Arbitrary (Ratio a) where - arbitrary = liftM2 (\x y -> x % if y == 0 then 1 else y) arbitrary arbitrary - coarbitrary = undefined - -instance Arbitrary Char where - arbitrary = elements ([' ', '\n', '\0'] ++ ['a'..'h']) - coarbitrary c = variant (fromEnum c `rem` 4) - -instance Arbitrary Ordering where - arbitrary = elements [LT, EQ, GT] - coarbitrary LT = variant 0 - coarbitrary EQ = variant 1 - coarbitrary GT = variant 2 - -instance Arbitrary a => Arbitrary (S.MaybeS a) where - arbitrary = frequency [ (1, return S.NothingS) - , (3, liftM S.JustS arbitrary) ] - coarbitrary S.NothingS = variant 0 - coarbitrary (S.JustS a) = variant 1 . coarbitrary a - -instance (Arbitrary a, Arbitrary b) => Arbitrary (a :*: b) where - arbitrary = do x <- arbitrary - y <- arbitrary - return ( x :*: y ) - coarbitrary (a:*:b) = coarbitrary a . coarbitrary b - -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) - => Arbitrary (a, b, c, d ,e ) - where - arbitrary = liftM5 (,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary - coarbitrary (a, b, c, d, e) = - coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d . coarbitrary e - -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f) - => Arbitrary (a, b, c, d, e, f) - where - arbitrary = liftM6 (,,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary arbitrary - coarbitrary (a, b, c, d, e, f) = - coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d . coarbitrary e . coarbitrary f - -liftM6 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m r -liftM6 f m1 m2 m3 m4 m5 m6 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6) } - -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f, Arbitrary g) - => Arbitrary (a, b, c, d, e, f, g) - where - arbitrary = liftM7 (,,,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary arbitrary arbitrary - coarbitrary (a, b, c, d, e, f, g) = - coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d . coarbitrary e . coarbitrary f . coarbitrary g - -liftM7 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m a7 -> m r -liftM7 f m1 m2 m3 m4 m5 m6 m7 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7 ; return (f x1 x2 x3 x4 x5 x6 x7) } - - ------------------------------------------------------------------------- --- Arbitrary instance for Stream - -instance (S.UA a, Arbitrary a) => Arbitrary (S.UArr a) where - arbitrary = do xs <- arbitrary - return $ S.toU xs - coarbitrary = undefined - --- To let us generate two UArrs of equal length -data ELUArrs a b = ELUArrs !(S.UArr a) !(S.UArr b) - deriving (Show, Eq) - -instance (S.UA a, S.UA b, Arbitrary a, Arbitrary b) => Arbitrary (ELUArrs a b) where - arbitrary = do n <- arbitrary - xs <- mapM (const arbitrary) $ replicate n 0 - ys <- mapM (const arbitrary) $ replicate n 0 - return $ ELUArrs (S.toU xs) (S.toU ys) - coarbitrary = undefined - -data ELUArrs3 a b c = ELUArrs3 !(S.UArr a) !(S.UArr b) !(S.UArr c) - deriving (Show, Eq) - -instance (S.UA a, S.UA b, S.UA c, Arbitrary a, Arbitrary b, Arbitrary c) => - Arbitrary (ELUArrs3 a b c) where - arbitrary = do n <- arbitrary - xs <- mapM (const arbitrary) $ replicate n 0 - ys <- mapM (const arbitrary) $ replicate n 0 - zs <- mapM (const arbitrary) $ replicate n 0 - return $ ELUArrs3 (S.toU xs) (S.toU ys) (S.toU zs) - coarbitrary = undefined - -data PosUArr = PosUArr !(S.UArr Int) - deriving (Show, Eq) - -instance Arbitrary PosUArr where - arbitrary = do xs <- arbitrary - -- this isn't really uniform, but whatever - return $ PosUArr (S.toU . map abs $ xs) - coarbitrary = undefined - -data Ind2LenUArr a = Ind2LenUArr !(S.UArr a) !Int !Int !Int - deriving (Show, Eq) - -instance (Arbitrary a, S.UA a) => Arbitrary (Ind2LenUArr a) where - arbitrary = do xs <- arbitrary - index1 <- fmap (`mod` (length xs + 1)) arbitrary -- TODO: check that this length + 1 stuff is correct - index2 <- fmap (`mod` (length xs + 1)) arbitrary - len <- fmap (`mod` (length xs - (max index1 index2) + 1)) arbitrary - return $ Ind2LenUArr (S.toU xs) index1 index2 len - coarbitrary = undefined - -data BoundedIndex a = BoundedIndex !(S.UArr a) !Int - deriving (Show, Eq) - -instance (Arbitrary a, S.UA a) => Arbitrary (BoundedIndex a) where - arbitrary = do xs <- arbitrary - index <- fmap (`mod` (length xs + 1)) arbitrary - return $ BoundedIndex (S.toU xs) index - coarbitrary = undefined - -data CombineGen a = CombineGen !(S.UArr Bool) !(S.UArr a) !(S.UArr a) - deriving (Show, Eq) - -instance (Arbitrary a, S.UA a) => Arbitrary (CombineGen a) where - arbitrary = do fs <- arbitrary - -- don't want to depend on arrow, but I'm not sure why not - let (xl, yl) = (\(x, y) -> (length x, length y)) $ partition id fs - -- really ugly way to generate arbitraries of specific length - xs <- mapM (const arbitrary) [1..xl] - ys <- mapM (const arbitrary) [1..yl] - return $ CombineGen (S.toU fs) (S.toU xs) (S.toU ys) - coarbitrary = undefined - -{- -instance (Arbitrary a, Arbitrary s) => Arbitrary (S.Step a s) where - arbitrary = do x <- arbitrary - a <- arbitrary - s <- arbitrary - return $ case x of - LT -> S.Yield a s - EQ -> S.Skip s - GT -> S.Done - coarbitrary = error "No coarbitrary for Step a s" --} - --- existential state type -{- -instance (Arbitrary a) => Arbitrary (S.Stream a) where - coarbitrary = error "No coarbitrary for Streams" - arbitrary = do xs <- arbitrary :: Gen [a] - skips <- arbitrary :: Gen [Bool] -- random Skips - return (stream' (zip xs skips)) - where - -- | Construct an abstract stream from a list, with Steps in it. - stream' :: [(a,Bool)] -> S.Stream a - stream' xs0 = S.Stream next (S.L xs0) - where - next (S.L []) = S.Done - next (S.L ((x,True ):xs)) = S.Yield x (S.L xs) - next (S.L ((_,False):xs)) = S.Skip (S.L xs) - -instance Show a => Show (S.Stream a) where - show = show . S.unstream - -instance Eq a => Eq (S.Stream a) where - xs == ys = S.unstream xs == S.unstream ys --} - ------------------------------------------------------------------------- - -class Model a b where - model :: a -> b -- get the abstract vale from a concrete value - -instance S.UA a => Model (S.UArr a) [a] where model = S.fromU - -instance S.UA a => Model (S.UArr a) (S.UArr a) where model = id -instance Model A A where model = id -instance Model B B where model = id -instance Model Bool Bool where model = id -instance Model Int Int where model = id -instance Model N N where model = id -instance Model OrdA OrdA where model = id -instance Model Ordering Ordering where model = id - -instance (Model a a , Model b b) => Model (a:*:b) (a,b) where - model (x:*:y) = (model x, model y) - --- not really moral -instance Functor ((:*:) a) where - fmap f (x:*:y) = (x :*: f y) - --- More structured types are modeled recursively, using the NatTrans class from Gofer. -class (Functor f, Functor g) => NatTrans f g where - eta :: f a -> g a - -instance NatTrans [] [] where eta = id -instance NatTrans Maybe Maybe where eta = id - -instance NatTrans ((->) A) ((->) A) where eta = id -instance NatTrans ((->) B) ((->) B) where eta = id -instance NatTrans ((->) N) ((->) N) where eta = id -instance NatTrans ((->) C) ((->) C) where eta = id - -instance Model f g => NatTrans ((,) f) ((,) g) - where eta (f,a) = (model f, a) -instance Model f g => NatTrans ((:*:) f) ((:*:) g) - where eta (f:*:a) = (model f:*: a) - -instance (NatTrans m n, Model a b) => Model (m a) (n b) - where model x = fmap model (eta x) diff --git a/tests/notes b/tests/notes deleted file mode 100644 --- a/tests/notes +++ /dev/null @@ -1,46 +0,0 @@ - import Data.Array.Vector - - main = print . sumU $ zipWithU (*) - (enumFromToU 1 (100000000 :: Int)) - (enumFromToU 2 (100000001 :: Int)) - -A subset of the NDP arrays library. After stream fusion kicks in, -this compiles to the following (very nice!) core: - - {-# LANGUAGE MagicHash #-} - - import GHC.Prim - import GHC.Base - - go :: Int# -> Int# -> Int# -> Int# - go a b c = - case b ># 100000000# of - False -> - case a ># 100000001# of - False -> - go ((+#) a 1#) - ((+#) b 1#) - ((+#) c ((*#) b a)) - True -> c - True -> c - - main = print (I# (go 2# 1# 0#)) - -Which is exactly what we want, and much the same as this C: - -Which shows up some differences between the native code generator and the -C backend: - - -fvia-C -O2 -optc-O: - - $ time ./T_c - 677921401802298880 - ./T_c 0.21s user 0.00s system 98% cpu 0.213 total - - -fasm -O2 - - $ time ./T_asm - 677921401802298880 - ./T_c 0.26s user 0.00s system 94% cpu 0.276 total - -And now diff --git a/tests/type-correct.hs b/tests/type-correct.hs deleted file mode 100644 --- a/tests/type-correct.hs +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/sh - -echo "Checking type correctness ... " - -f=`mktemp` - -for i in Data/Array/Vector.hs ; do - ghci -cpp -Iinclude -v0 $i < /dev/null -done > $f 2>&1 - -if cmp -s $f /dev/null ; then - echo "Passed" - true -else - echo "Failed" - cat $f - false -fi diff --git a/uvector.cabal b/uvector.cabal --- a/uvector.cabal +++ b/uvector.cabal @@ -1,5 +1,5 @@ name: uvector -version: 0.1.0.4 +version: 0.1.0.5 license: BSD3 license-file: LICENSE author: Manuel Chakravarty, Gabriele Keller, Roman Leshchinskiy, Don Stewart