packages feed

uvector 0.1.0.4 → 0.1.0.5

raw patch · 165 files changed

+64/−7682 lines, 165 filesnew-uploader

Files

Data/Array/Vector.hs view
@@ -44,6 +44,7 @@   snocU,   -- uncons   appendU,+  concatU,   headU,   lastU,   tailU,@@ -62,6 +63,8 @@    foldlU,   foldl1U,+  foldrU,+  foldr1U,   foldl1MaybeU,    -- ** Logical operations
Data/Array/Vector/Stream.hs view
@@ -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
Data/Array/Vector/Strict/Basics.hs view
@@ -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.
TODO view
@@ -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
− examples/Makefile 
@@ -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--
− examples/README 
@@ -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=<N> --runs=<R> <INPUT> +RTS -N<T>--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.---
− examples/barhesHut/BarnesHut.hs 
@@ -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 ()-
− examples/barhesHut/BarnesHutGen.hs 
@@ -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"
− examples/barhesHut/BarnesHutSeq.hs 
@@ -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-----
− examples/concomp/AwShU.hs 
@@ -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-
− examples/concomp/AwShUP.hs 
@@ -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-
− examples/concomp/Graph.hs 
@@ -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-
− examples/concomp/HybU.hs 
@@ -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--
− examples/concomp/HybUP.hs 
@@ -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-
− examples/concomp/Makefile 
@@ -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)-
− examples/concomp/README 
@@ -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)-
− examples/concomp/concomp.hs 
@@ -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"]-                   "<none>"--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)-
− examples/concomp/mkg.hs 
@@ -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-
− examples/dotp/DotPPar.hs 
@@ -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)-
− examples/dotp/DotPSeq.hs 
@@ -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)-
− examples/dotp/DotPVect.hs 
@@ -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)-
− examples/dotp/Makefile 
@@ -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)-
− examples/dotp/README 
@@ -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-
− examples/dotp/dotp.hs 
@@ -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 ()-    -
− examples/fusion/DotP.hs 
@@ -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)-
− examples/fusion/Map_Map.hs 
@@ -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-
− examples/fusion/Map_Map_Replicate.hs 
@@ -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-
− examples/fusion/Map_Replicate.hs 
@@ -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-
− examples/fusion/runtst.sh 
@@ -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-
− examples/lib/Bench/Benchmark.hs 
@@ -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-
− examples/lib/Bench/Options.hs 
@@ -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-
− examples/lib/Bench/Time.hs 
@@ -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-
− examples/lib/Makefile 
@@ -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--
− examples/mk/common.mk 
@@ -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-
− examples/mk/test.mk 
@@ -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)-
− examples/primes/H98.hs 
@@ -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])-
− examples/primes/Makefile 
@@ -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-
− examples/primes/PrimPar.hs 
@@ -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 --
− examples/primes/PrimSeq.hs 
@@ -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)))-
− examples/primes/README 
@@ -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.-
− examples/primes/primes.hs 
@@ -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-
− examples/primespj/Primes.hs 
@@ -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 ()
− examples/primespj/PrimesVect.hs 
@@ -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:]
− examples/qsort/Makefile 
@@ -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
− examples/qsort/QSort.hs 
@@ -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 ()-
− examples/qsort/QSortPar.hs 
@@ -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-   ----
− examples/qsort/QSortSeq.hs 
@@ -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]
− examples/qsort/QSortVect.hs 
@@ -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))
− examples/quickcheck/Makefile 
@@ -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 $<-
− examples/quickcheck/Testsuite.hs 
@@ -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--
− examples/quickcheck/Testsuite/Preproc.hs 
@@ -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-
− examples/quickcheck/Testsuite/Testcase.hs 
@@ -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-
− examples/quickcheck/Testsuite/Utils.hs 
@@ -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--}-
− examples/quickcheck/tests/BUArr.hs 
@@ -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)-  -}-  |])-
− examples/quickcheck/tests/Distributed.hs 
@@ -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--  |])-
− examples/quickcheck/tests/UnliftedSU.hs 
@@ -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-  |])-
− examples/quickcheck/tests/Unlifted_Basics.hs 
@@ -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)-  |])-
− examples/quickcheck/tests/Unlifted_Combinators.hs 
@@ -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-  |])-
− examples/quickcheck/tests/Unlifted_Fusion.hs 
@@ -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-  |])-
− examples/quickcheck/tests/Unlifted_Permutes.hs 
@@ -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)- |])-
− examples/quickcheck/tests/Unlifted_Subarrays.hs 
@@ -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)-  |])-
− examples/quickcheck/tests/Unlifted_Sums.hs 
@@ -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)- |])-
− examples/quickhull/Makefile 
@@ -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-
− examples/quickhull/QH.hs 
@@ -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))-
− examples/quickhull/Types.hs 
@@ -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))--
− examples/quickhull/quickhull.hs 
@@ -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-
− examples/ref/DotProd.hs 
@@ -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)
− examples/ref/MatVecMul.hs 
@@ -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)
− examples/ref/README 
@@ -1,2 +0,0 @@-These are reference implementations of dot product and matrix-vector -multiplication for comparison purposes.  They don't use parallel arrays.
− examples/ref/dotprod.c 
@@ -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;-}
− examples/ref/dotprod.h 
@@ -1,6 +0,0 @@-#ifndef DOTPROD_H-#define DOTPROD_H--float cvectorDP (float *v1, float *v2, int n);--#endif
− examples/ref/matvecmul.c 
@@ -1,23 +0,0 @@-// gcc -c -O2 matvecmul.c--#include <malloc.h>--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;-}
− examples/ref/matvecmul.h 
@@ -1,6 +0,0 @@-#ifndef MATVECMUL_H-#define MATVECMUL_H--float cmvm (float *v1, float *v2, int n);--#endif
− examples/simple/DotProd.hs 
@@ -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 ---}
− examples/simple/MapInc.hs 
@@ -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)) #)-	  }-      };---}
− examples/simple/PrefixSum.hs 
@@ -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)) #)-      };---}
− examples/simple/SegPrefixSum.hs 
@@ -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 ---}
− examples/simple/SegSum.hs 
@@ -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;-}---}
− examples/simple/Sum.hs 
@@ -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) #)-		}-	    };---}
− examples/smvm/Makefile 
@@ -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-
− examples/smvm/README 
@@ -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.-
− examples/smvm/SMVMPar.hs 
@@ -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))-
− examples/smvm/SMVMSeq.hs 
@@ -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))-
− examples/smvm/SMVMVect.hs 
@@ -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 :]-
− examples/smvm/mksm.c 
@@ -1,187 +0,0 @@-#include <unistd.h>-#include <stdlib.h>-#include <stdio.h>-#include <fcntl.h>-#include <string.h>-#include <ctype.h>--#include <HsFFI.h>--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;-}-
− examples/smvm/smvm-c.c 
@@ -1,89 +0,0 @@-#include <unistd.h>-#include <stdio.h>-#include <fcntl.h>-#include <stdlib.h>-#include <time.h>--#include <HsFFI.h>--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)) );-}-
− examples/smvm/smvm.hs 
@@ -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)-
− examples/spec-constr/Makefile 
@@ -1,8 +0,0 @@-TESTDIR = ..-PROGS = spec-constr-include $(TESTDIR)/mk/test.mk--spec-constr.o: Pipelines.hi--spec-constr: Pipelines.o $(BENCHLIB)-
− examples/spec-constr/Pipelines.hs 
@@ -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)-
− examples/spec-constr/spec-constr.hs 
@@ -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"]-                   "<none>"--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-
− examples/sumsq/SumSq.hs 
@@ -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-
− examples/unit/TestBUArr.hs 
@@ -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))
− examples/unit/TestUArr.hs 
@@ -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))
− tests/Examples/Test.hs 
@@ -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)
− tests/Examples/fuse.hs 
@@ -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)-
− tests/Examples/prod.hs 
@@ -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)-
− tests/Examples/raw.hs 
@@ -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-
− tests/Examples/real2Frac.hs 
@@ -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
− tests/Fusion/Test.hs 
@@ -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)
− tests/Fusion/and.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print (andU (replicateU 100 True))-
− tests/Fusion/append.hs 
@@ -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))
− tests/Fusion/cons.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print . sumU . consU 0xdeadbeef . replicateU (100000000::Int) $ (8::Int)-
− tests/Fusion/drop.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . lengthU . dropU 100000 . replicateU 1000000 $ (7 :: Int)-
− tests/Fusion/elem.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . elemU 100 . mapU (`shiftL` 1) . enumFromToU 1 $ (10000 :: Int)-
− tests/Fusion/empty.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print . sumU $ consU (0xdeadbeef::Int) emptyU-
− tests/Fusion/eq.hs 
@@ -1,6 +0,0 @@--import Data.Array.Vector-main = print (eqU (replicateU 100000000 True)-                  (replicateU 100000000 True))--
− tests/Fusion/filter.hs 
@@ -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)-
− tests/Fusion/find.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . findU (==100) . mapU (`shiftL` 1) . enumFromToU 1 $ (10000 :: Int)-
− tests/Fusion/findIndex.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . findIndexU (==100) . mapU (`shiftL` 1) . enumFromToU 1 $ (10000 :: Int)-
− tests/Fusion/foldl1.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . foldl1U (+) . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int)-
− tests/Fusion/from-to.hs 
@@ -1,2 +0,0 @@-import Data.Array.Vector-main = print . head . toList . fromList $ replicate 1 (7::Int)
− tests/Fusion/head.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . headU . mapU (`shiftL` 1) . replicateU 1000000000 $ (7 :: Int)-
− tests/Fusion/index.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print . (\arr -> arr `indexU` 42) . mapU (subtract 6) . replicateU 10000000 $ (7 :: Int)-
− tests/Fusion/indexed.hs 
@@ -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)-
− tests/Fusion/init.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . lengthU . initU . replicateU 1000000 $ (7 :: Int)-
− tests/Fusion/last.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . lastU . mapU (`shiftL` 1) . replicateU 1000000000 $ (7 :: Int)-
− tests/Fusion/length-bool.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print (lengthU (replicateU 1 True))-
− tests/Fusion/length-char.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print (lengthU (replicateU 1 'x'))-
− tests/Fusion/length-double.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print (lengthU (replicateU 1 (pi :: Double)))-
− tests/Fusion/length-float.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print (lengthU (replicateU 1 (pi :: Float)))-
− tests/Fusion/length-int16.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Int-main = print (lengthU (replicateU 1 (7 :: Int16)))-
− tests/Fusion/length-int32.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Int-main = print (lengthU (replicateU 1 (7 :: Int32)))-
− tests/Fusion/length-int64.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Int-main = print (lengthU (replicateU 1 (7 :: Int64)))-
− tests/Fusion/length-int8.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Int-main = print (lengthU (replicateU 1 (7 :: Int8)))-
− tests/Fusion/length-unit.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print (lengthU (replicateU 1 ()))-
− tests/Fusion/length-word.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Word-main = print (lengthU (replicateU 1 (7 :: Word)))-
− tests/Fusion/length-word16.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Word-main = print (lengthU (replicateU 1 (7 :: Word16)))-
− tests/Fusion/length-word32.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Word-main = print (lengthU (replicateU 1 (7 :: Word32)))-
− tests/Fusion/length-word64.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Word-main = print (lengthU (replicateU 1 (7 :: Word64)))-
− tests/Fusion/length-word8.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Word-main = print (lengthU (replicateU 1 (7 :: Word8)))-
− tests/Fusion/length.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print . lengthU . enumFromToU 1 $ (100000000 :: Int)-
− tests/Fusion/lookup.hs 
@@ -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))
− tests/Fusion/map.hs 
@@ -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)-
− tests/Fusion/maximum.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . maximumU . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int)-
− tests/Fusion/maximumBy.hs 
@@ -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)-
− tests/Fusion/minimum.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . minimumU . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int)-
− tests/Fusion/minimumBy.hs 
@@ -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)-
− tests/Fusion/null-ndp.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector -- Parallel.Unlifted-main = print . sumU . mapU fstS . indexedU . enumFromToU 1 $ (100000000 :: Int)-
− tests/Fusion/null.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print . nullU . filterU (>10) . mapU (subtract 6) . enumFromToU 1 $ (100000000 :: Int)-
− tests/Fusion/or.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print (orU (replicateU 100 True))-
− tests/Fusion/product.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . productU . mapU (*2) . mapU (`shiftL` 2) $ replicateU (100000000 :: Int) (5::Int)-
− tests/Fusion/repeat.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . sumU . repeatU 10 $ replicateU (10000000 :: Int) (5::Int) -
− tests/Fusion/replicate.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print . sumU . mapU (subtract 7) . replicateU 10000000 $ (7 :: Int)-
− tests/Fusion/singleton.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print . sumU $ consU (10::Int) (singletonU 2)-
− tests/Fusion/snoc.hs 
@@ -1,3 +0,0 @@-import Data.Array.Vector-main = print . sumU . (\e -> snocU e 0xdeadbeef) . replicateU (100000000::Int) $ (8::Int)-
− tests/Fusion/sum-complex.hs 
@@ -1,5 +0,0 @@-import Data.Array.Vector-import Data.Complex--main = print . sumU $ replicateU (100000000 :: Int) (1 :+ 1 ::Complex Double)-
− tests/Fusion/sum-ratio.hs 
@@ -1,5 +0,0 @@-import Data.Array.Vector-import Data.Ratio--main = print . sumU $ replicateU (100000000 :: Int) (1 % 2 :: Rational)-
− tests/Fusion/sum.hs 
@@ -1,8 +0,0 @@-import Data.Array.Vector-import Data.Bits--main = print . sumU-             . mapU (*2)-             . mapU (`shiftL` 2)-             $ replicateU (100000000 :: Int) (5::Int)-
− tests/Fusion/tail.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . lengthU . tailU . replicateU 1000000 $ (7 :: Int)-
− tests/Fusion/take.hs 
@@ -1,4 +0,0 @@-import Data.Array.Vector-import Data.Bits-main = print . lengthU . takeU 100000 . replicateU 1000000 $ (7 :: Int)-
− tests/Fusion/takeWhile.hs 
@@ -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!
− tests/Fusion/unfold.hs 
@@ -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
− tests/Fusion/zip.hs 
@@ -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))-
− tests/Fusion/zipwith.hs 
@@ -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)-
− tests/Fusion/zipwith3.hs 
@@ -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))-
− tests/Makefile 
@@ -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-
− tests/Performance.hs 
@@ -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---------------------------------------------------------------------------
− tests/Properties/Monomorphic/Base.hs 
@@ -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
− tests/Properties/Monomorphic/UVector.hs 
@@ -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--}
− tests/Properties/Specific.hs 
@@ -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)
− tests/Properties/Test.hs 
@@ -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-    ]--}
− tests/Properties/Utils.hs 
@@ -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)
− tests/notes 
@@ -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
− tests/type-correct.hs 
@@ -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
uvector.cabal view
@@ -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