Commit 6d137b8a authored by keller@cse.unsw.edu.au's avatar keller@cse.unsw.edu.au
Browse files

QSort and lib funs

parent 367ea1ae
......@@ -22,7 +22,7 @@ module Data.Array.Parallel.Stream.Flat (
toStream, fromStream,
mapS, filterS, foldS, fold1MaybeS, scanS, scan1S, mapAccumS,
zipWithS, zipWith3S, zipS,
zipWithS, zipWith3S, zipS, combineS,
findS, findIndexS,
......
......@@ -81,6 +81,8 @@ replicateEachS n (Stream next s _) =
next' (k :*: JustS (Box x) :*: s) =
Yield x (k-1 :*: JustS (Box x) :*: s)
-- | Concatenation
--
(+++) :: Stream a -> Stream a -> Stream a
......
......@@ -15,7 +15,7 @@
module Data.Array.Parallel.Stream.Flat.Combinators (
mapS, filterS, foldS, fold1MaybeS, scanS, scan1S, mapAccumS,
zipWithS, zipWith3S, zipS
zipWithS, zipWith3S, zipS, combineS
) where
import Data.Array.Parallel.Base (
......@@ -47,6 +47,8 @@ filterS f (Stream next s n) = Stream next' s n
Yield x s' | f x -> Yield x s'
| otherwise -> Skip s'
-- | Folding
--
foldS :: (b -> a -> b) -> b -> Stream a -> b
......@@ -113,6 +115,27 @@ mapAccumS f acc (Stream step s n) = Stream step' (s :*: Box acc) n
in
Yield y (s' :*: Box acc')
combineS:: Stream Bool -> Stream a -> Stream a -> Stream a
{-# INLINE [1] combineS #-}
combineS (Stream next1 s m) (Stream nextS1 t1 n1) (Stream nextS2 t2 n2) =
Stream next (s :*: t1 :*: t2) m
where
{-# INLINE next #-}
next (s :*: t1 :*: t2) =
case next1 s of
Done -> Done
Skip s' -> Skip (s' :*: t1 :*: t2)
Yield c s' -> if c
then case nextS1 t1 of
Done -> error "combineS: stream 1 terminated unexpectedly"
Skip t1' -> Skip (s :*: t1' :*: t2)
Yield x t1' -> Yield x (s' :*: t1' :*: t2)
else case nextS2 t2 of
Done -> error "combineS: stream 1 terminated unexpectedly"
Skip t2' -> Skip (s :*: t1 :*: t2')
Yield x t2' -> Yield x (s' :*: t1 :*: t2')
-- | Zipping
--
-- FIXME: The definition below duplicates work if the second stream produces
......
......@@ -15,7 +15,8 @@
module Data.Array.Parallel.Stream.Segmented (
SStream(..),
segmentS, foldValuesSS
segmentS, foldValuesSS,
combineSS
) where
import Data.Array.Parallel.Base (
......@@ -33,7 +34,7 @@ segmentS = SStream
foldValuesSS :: (a -> b -> a) -> a -> SStream b -> Stream a
{-# INLINE [1] foldValuesSS #-}
foldValuesSS f z (SStream (Stream nexts ss ns) (Stream nextv vs nv)) =
foldValuesSS f z (SStream (Stream nexts ss ns) (Stream nextv vs nv)) =
Stream next (NothingS :*: Box z :*: ss :*: vs) ns
where
{-# INLINE next #-}
......@@ -54,3 +55,38 @@ foldValuesSS f z (SStream (Stream nexts ss ns) (Stream nextv vs nv)) =
Skip vs' -> Skip (JustS n :*: Box x :*: ss :*: vs')
Yield y vs' -> Skip (JustS (n-1) :*: Box (f x y) :*: ss :*: vs')
combineSS:: (Stream Bool) -> SStream a -> SStream a -> Stream a
{-# INLINE [1] combineSS #-}
combineSS (Stream nextf sf nf)
(SStream (Stream nexts1 ss1 ns1) (Stream nextv1 vs1 nv1))
(SStream (Stream nexts2 ss2 ns2) (Stream nextv2 vs2 nv2)) =
Stream next (NothingS :*: Box True :*: sf :*: ss1 :*: vs1 :*: ss2 :*: vs2) (nv1+nv2)
where
{-# INLINE next #-}
next (NothingS :*: f :*: sf :*: ss1 :*: vs1 :*: ss2 :*: vs2) =
case nextf sf of
Done -> Done
Skip sf' -> Skip (NothingS :*: f :*: sf' :*: ss1 :*: vs1 :*: ss2 :*: vs2)
Yield c sf' -> if c
then case nexts1 ss1 of
Done -> Done
Skip ss1' -> Skip (NothingS :*: f :*: sf :*: ss1' :*: vs1 :*: ss2 :*: vs2)
Yield n ss1' -> Skip (JustS n :*: Box c :*: sf' :*: ss1' :*: vs1 :*: ss2 :*: vs2)
else case nexts2 ss2 of
Done -> Done
Skip ss2' -> Skip (NothingS :*: f :*: sf :*: ss1 :*: vs1 :*: ss2' :*: vs2)
Yield n ss2' -> Skip (JustS n :*: Box c :*: sf' :*: ss1 :*: vs1 :*: ss2' :*: vs2)
next (JustS 0 :*: _ :*: sf :*: ss1 :*: vs1 :*: ss2 :*: vs2) =
Skip (NothingS :*: Box True :*: sf :*: ss1 :*: vs1 :*: ss2 :*: vs2)
next (JustS n :*: Box True :*: sf :*: ss1 :*: vs1 :*: ss2 :*: vs2) =
case nextv1 vs1 of
Done -> Done
Skip vs1' -> Skip (JustS n :*: Box True :*: sf :*: ss1 :*: vs1' :*: ss2 :*: vs2)
Yield x vs1' -> Yield x (JustS (n-1) :*: Box True :*: sf :*: ss1 :*: vs1' :*: ss2 :*: vs2)
next (JustS n :*: Box False :*: sf :*: ss1 :*: vs1 :*: ss2 :*: vs2) =
case nextv2 vs2 of
Done -> Done
Skip vs2' -> Skip (JustS n :*: Box False :*: sf :*: ss1 :*: vs1 :*: ss2 :*: vs2')
Yield x vs2' -> Yield x (JustS (n-1) :*: Box False :*: sf :*: ss1 :*: vs1 :*: ss2 :*: vs2')
\ No newline at end of file
......@@ -25,7 +25,7 @@ module Data.Array.Parallel.Unlifted (
UArr, USegd, SUArr,
-- * Strict pairs and sums (reexported)
(:*:)(..), fstS, sndS,
(:*:)(..), fstS, sndS, uncurryS, curryS,
-- * Basic operations
lengthU, nullU, emptyU, singletonU, consU, unitsU, replicateU, (!:), (+:+),
......@@ -40,9 +40,10 @@ module Data.Array.Parallel.Unlifted (
-- * Permutations
permuteU, bpermuteU, bpermuteDftU, reverseU, updateU,
-- * Higher-order operations
mapU, zipWithU, zipWith3U,
filterU,
filterU, filterFlagsU,
foldlU, foldl1U,
{-foldrU, foldr1U,-}
foldU, fold1U,
......@@ -51,6 +52,10 @@ module Data.Array.Parallel.Unlifted (
scanU, scan1U,
mapAccumLU,
-- Segmented filter and combines
filterSU,
combineU, combineSU,
-- * Searching
elemU, notElemU,
{-lookupU, indexOfU,-}
......@@ -85,10 +90,13 @@ module Data.Array.Parallel.Unlifted (
UIO(..),
-- * Segmentation
concatSU, flattenSU, (>:), segmentU,
concatSU, flattenSU, (>:), segmentU, segmentArrU,
-- * Basic operations (segmented)
lengthSU, replicateSU,
lengthSU, replicateSU, (+:+^),
-- * Basic operations lifted
lengthsSU,
-- * Zipping (segmented)
fstSU, sndSU, zipSU,
......
......@@ -39,10 +39,11 @@ module Data.Array.Parallel.Unlifted.Flat (
-- * Permutations
permuteU, bpermuteU, bpermuteDftU, reverseU, updateU,
combineU,
-- * Higher-order operations
mapU, zipWithU, zipWith3U,
filterU,
filterU, filterFlagsU,
foldlU, foldl1U, foldl1MaybeU,
{-foldrU, foldr1U,-}
foldU, fold1U, fold1MaybeU,
......
......@@ -17,20 +17,20 @@
--
module Data.Array.Parallel.Unlifted.Flat.Combinators (
mapU, filterU,
mapU, filterU, filterFlagsU,
foldlU, foldl1U, foldl1MaybeU, {-foldrU, foldr1U,-}
foldU, fold1U, fold1MaybeU,
scanlU, scanl1U, {-scanrU, scanr1U,-} scanU, scan1U,
mapAccumLU,
zipU, zip3U, unzipU, unzip3U, fstU, sndU,
zipWithU, zipWith3U
zipWithU, zipWith3U, combineU,
) where
import Data.Array.Parallel.Base (
(:*:)(..), MaybeS(..), checkNotEmpty)
(:*:)(..), MaybeS(..), checkNotEmpty,fstS)
import Data.Array.Parallel.Stream (
mapS, filterS, foldS, fold1MaybeS, scan1S, scanS, mapAccumS,
zipWithS, zipWith3S)
zipWithS, zipWith3S, combineS)
import Data.Array.Parallel.Unlifted.Flat.UArr (
UA, UArr,
zipU, unzipU, fstU, sndU)
......@@ -55,6 +55,13 @@ filterU :: UA e => (e -> Bool) -> UArr e -> UArr e
{-# INLINE filterU #-}
filterU p = unstreamU . filterS p . streamU
-- |Extract all elements from an array according to a given flag array
--
filterFlagsU:: (UA e) => UArr Bool -> UArr e -> UArr e
{-# INLINE filterFlagsU #-}
filterFlagsU flags arr =
sndU $ filterU fstS $ zipU flags arr
-- |Array reduction proceeding from the left
--
foldlU :: UA a => (b -> a -> b) -> b -> UArr a -> b
......@@ -162,4 +169,8 @@ unzip3U a = let (a12 :*: a3) = unzipU a
(a1 :*: a2 :*: a3)
-- fstU and sndU reexported from UArr
-- |
combineU :: UA a
=> UArr Bool -> UArr a -> UArr a -> UArr a
{-# INLINE combineU #-}
combineU f a1 a2 = unstreamU (combineS (streamU f) (streamU a1) (streamU a2))
......@@ -25,10 +25,13 @@ module Data.Array.Parallel.Unlifted.Segmented (
streamSU, unstreamSU,
-- * Segmentation
concatSU, flattenSU, (>:), segmentU, segdSU,
concatSU, flattenSU, (>:), segmentU, segmentArrU, segdSU,
-- * Basic operations
lengthSU, replicateSU, sliceIndexSU, extractIndexSU,
lengthSU, replicateSU, sliceIndexSU, extractIndexSU, (+:+^),
-- * Basic operations lifted
lengthsSU,
-- * Subarrays
sliceSU, extractSU,
......@@ -46,6 +49,10 @@ module Data.Array.Parallel.Unlifted.Segmented (
{-fold1SU,-}
{-scanSU, scan1SU,-}
-- filter and combines
filterSU,
combineSU,
-- * Logical operations
andSU, orSU,
......
......@@ -18,17 +18,17 @@
module Data.Array.Parallel.Unlifted.Segmented.Basics (
lengthSU, replicateSU,
flattenSU, (>:), segmentU, concatSU,
flattenSU, (>:), segmentU, segmentArrU, concatSU,
sliceIndexSU, extractIndexSU,
fstSU, sndSU, zipSU,
enumFromToSU, enumFromThenToSU,
toSU, fromSU
toSU, fromSU,(+:+^)
) where
import Data.Array.Parallel.Base (
(:*:)(..))
import Data.Array.Parallel.Stream (
Step(..), Stream(..),
Step(..), Stream(..),SStream(..),(+++),
replicateEachS, zipS)
import Data.Array.Parallel.Unlifted.Flat (
UA, UArr,
......@@ -36,6 +36,9 @@ import Data.Array.Parallel.Unlifted.Flat (
mapU, fstU, sndU, zipU, zipWith3U, sumU,
toU, fromU,
streamU, unstreamU)
import Data.Array.Parallel.Unlifted.Segmented.Stream (streamSU,unstreamSU)
import Data.Array.Parallel.Unlifted.Segmented.SUArr (
SUArr, lengthSU, (>:), flattenSU, segdSU, lengthsSU, indicesSU,
lengthsToUSegd)
......@@ -60,6 +63,13 @@ segmentU :: (UA e', UA e) => SUArr e' -> UArr e -> SUArr e
{-# INLINE segmentU #-}
segmentU template arr = segdSU template >: arr
-- |Segment an array according to the segmentation of the first argument
--
segmentArrU :: (UA e) => UArr Int -> UArr e -> SUArr e
{-# INLINE segmentArrU #-}
segmentArrU lengths arr = (lengthsToUSegd lengths) >: arr
-- |Concatenate the subarrays of an array of arrays
--
concatSU :: UA e => SUArr e -> UArr e
......@@ -145,6 +155,15 @@ enumFromThenToEachS n (Stream next s _) =
next' (n :*: start :*: delta :*: s) =
Yield (toEnum start) (n-1 :*: start+delta :*: delta :*: s)
-- |Concatenate two arrays
--
(+:+^) :: UA e => SUArr e -> SUArr e -> SUArr e
{-# INLINE (+:+^) #-}
a1 +:+^ a2 = unstreamSU $ SStream (segs1 +++ segs2) (vals1 +++ vals2)
where
(SStream segs1 vals1) = streamSU a1
(SStream segs2 vals2) = streamSU a2
-- |Conversion
-- -----------
......
......@@ -19,21 +19,25 @@
module Data.Array.Parallel.Unlifted.Segmented.Combinators (
mapSU, zipWithSU,
foldlSU, foldSU, {-fold1SU,-} {-scanSU,-} {-scan1SU,-}
combineSU, filterSU
) where
import Data.Array.Parallel.Base (
sndS)
import Data.Array.Parallel.Stream (
Stream, SStream, mapS, foldValuesSS)
Stream, SStream, mapS, foldValuesSS, combineSS)
import Data.Array.Parallel.Unlifted.Flat (
UA, UArr, mapU, zipWithU,
unstreamU)
unstreamU, streamU)
import Data.Array.Parallel.Unlifted.Segmented.SUArr (
SUArr, segdSU, (>:))
SUArr, segdSU, flattenSU, (>:))
import Data.Array.Parallel.Unlifted.Segmented.Basics (
concatSU)
concatSU, segmentArrU,segmentU)
import Data.Array.Parallel.Unlifted.Segmented.Stream (
streamSU)
import Data.Array.Parallel.Unlifted.Flat.Combinators (
filterU)
import Debug.Trace
......@@ -58,3 +62,23 @@ foldlSU f z = unstreamU . foldValuesSS f z . streamSU
foldSU :: UA a => (a -> a -> a) -> a -> SUArr a -> UArr a
foldSU = foldlSU
-- |Merge two segmented arrays according to flag array
--
combineSU:: UA a => UArr Bool -> SUArr a -> SUArr a -> UArr a
{-# INLINE combineSU #-}
combineSU fs xs1 xs2 =
unstreamU $ combineSS (streamU fs) (streamSU xs1) (streamSU xs2)
-- |Filter segmented array
--
filterSU:: (UA e) => (e -> Bool) -> SUArr e -> SUArr e
{-# INLINE filterSU #-}
filterSU p xssArr = segmentArrU newLengths flatData
where
flatData = filterU p $ flattenSU xssArr
segdFlags = segmentU xssArr $ mapU (\x -> if p x then 1 else 0) $ flattenSU xssArr
newLengths = foldSU (+) 0 segdFlags
......@@ -22,7 +22,7 @@ module Data.Array.Parallel.Unlifted.Segmented.SUArr (
SUArr, MSUArr,
-- * Basic operations on segmented parallel arrays
lengthSU, lengthsSU, indicesSU, segdSU,
lengthSU, lengthsSU, lengthsSU,indicesSU, segdSU,
flattenSU, (>:),
newMSU, unsafeFreezeMSU,
......
TESTDIR=.
include $(TESTDIR)/mk/test.mk
SUBDIRS = concomp dotp primes smvm
SUBDIRS = concomp dotp primes smvm qsort
.PHONY: all bench clean
......
TESTDIR = ..
PROGS = QSort
HCCFLAGS = -optc-O3 -fglasgow-exts -fbang-patterns -O2 -funbox-strict-fields -fliberate-case-threshold100 -fdicts-cheap -fno-method-sharing -fmax-simplifier-iterations6 -threaded -haddock
include $(TESTDIR)/mk/test.mk
QSortSeq.o:
QSortMain.o: QSortSeq.hi
QSort: QSortMain.hs QSortSeq.hs
~/ghc/compiler/ghc-inplace $(HCCFLAGS) --make -package ndp -fglasgow-exts -o QSort QSortMain.hs
#-ddump-simpl
\ No newline at end of file
module Main where
import QSortSeq
main = do
print qsortTest
\ No newline at end of file
{-# GHC_OPTIONS -fglasgow-exts #-}
--
-- TODO:
-- why is combineSS slower?
module QSortSeq
where
import Data.Array.Parallel.Unlifted
qsortTest =
-- (qsortList ([1..200000])) !!199999
lengthSU $ qsortLifted $ toSU ([[1..200000]]::[[Double]])
qsort:: UArr Double -> UArr Double
qsort xsarr
| xsLen < 2 = xsarr
| otherwise = smallerEq +:+ greater
where
xsLen = lengthU xsarr
pivot = xsarr !: (xsLen `div` 2)
smallerEq = filterU (<= pivot) xsarr
greater = filterU (> pivot) xsarr
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 appendSU (takenCU xssLen sorted) (appendSU equal (dropnCU xssLen sorted))
where
xssLen = lengthSU xssarr
xsLens = lengthsSU xssarr
pivots = indexSU xssarr $ mapU (flip div 2) xsLens
pivotss = replicateSU xsLens pivots
xarrLens = zipSU xssarr pivotss
sorted = qsortLifted $ (mapSU fstS $ filterSU (uncurryS (>)) xarrLens) +:+^
(mapSU fstS $ filterSU (uncurryS (<)) xarrLens)
equal = mapSU fstS $ filterSU (uncurryS (==)) xarrLens
-- smaller = qsortLifted $ mapSU fstS $ filterSU (uncurryS (<)) xarrLens
indexSU :: (UA e) => SUArr e -> UArr Int -> UArr e
{-# INLINE indexSU #-}
indexSU sArr inds = bpermuteU (flattenSU sArr) newInds
where
xsLens = lengthsSU sArr
newInds = zipWithU (+) inds $ scanU (+) 0 xsLens
filterFlagsCU:: (UA e) => UArr Bool -> SUArr e -> SUArr e
{-# INLINE filterFlagsCU #-}
filterFlagsCU flags xssArr = segmentArrU newLengths flatData
where
repFlags = flattenSU $ replicateSU (lengthsSU xssArr) flags
flatData = filterFlagsU repFlags $ flattenSU xssArr
newLengths = filterFlagsU flags $ lengthsSU xssArr
combineCU:: (UA e) => UArr Bool -> SUArr e -> SUArr e -> SUArr e
{-# INLINE combineCU #-}
combineCU flags xssArr1 xssArr2 = segmentArrU newLengths flatData
where
newLengths = combineU flags (lengthsSU xssArr1) (lengthsSU xssArr2)
repFlags = replicateSU newLengths flags
--flatData = combineSU flags xssArr1 xssArr2
flatData = combineU (flattenSU repFlags) (flattenSU xssArr1) (flattenSU xssArr2)
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 $ filterFlagsCU flags xssArr
res2 = f2 $ filterFlagsCU (mapU not flags) xssArr
appendSU:: (UA e) => SUArr e -> SUArr e -> SUArr e
{-# INLINE appendSU #-}
appendSU xssArr1 xssArr2 = segmentArrU newLengths flatData
where
len = lengthSU xssArr1 + lengthSU xssArr2
flags = mapU even $ enumFromToU 0 (len-1)
flatData = flattenSU $ combineCU flags xssArr1 xssArr2
newLengths = zipWithU (+) (lengthsSU xssArr1) (lengthsSU xssArr2)
-- there should be a better way to implent dropn and taken
-- it makes qsort terribly slow
takenCU:: (UA e) => Int -> SUArr e -> SUArr e
{-# INLINE takenCU #-}
takenCU n xssArr = filterFlagsCU flags xssArr
where
flags = mapU (<=n) $ enumFromToU 1 (lengthSU xssArr)
dropnCU:: (UA e) => Int -> SUArr e -> SUArr e
{-# INLINE dropnCU #-}
dropnCU n xssArr = filterFlagsCU flags xssArr
where
flags = mapU (>n) $ enumFromToU 1 (lengthSU xssArr)
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]
\ No newline at end of file
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment