Parallel list version using 'par'
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>
Mon, 7 Jun 2010 01:59:43 +0000 (01:59 +0000)
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>
Mon, 7 Jun 2010 01:59:43 +0000 (01:59 +0000)
examples/quickhull/Makefile
examples/quickhull/QuickHull.hs

index 7d8decd..a0a1c22 100644 (file)
@@ -7,7 +7,7 @@ quickhull_DPH = quickhull
 quickhull_SOURCES = vect.hs QuickHullVect.hs Types.hs
 
 QuickHull_SOURCES = QuickHull.hs
-QuickHull_FLAGS   = -O2
+QuickHull_FLAGS   = -O2 -package dph-prim-seq
 
 quickhullSVG_DPH = quickhullSVG
 quickhullSVG_SOURCES = vectSVG.hs QuickhullVect.hs Types.hs SVG.hs TestData.hs
index 3bce2f3..627586b 100644 (file)
@@ -1,8 +1,16 @@
+-- This program is heavily GC bound unless we use a very large heap (eg, -H500M)
+
+import GHC.Conc (par, pseq)
+
+import System.IO
+import Control.Exception (evaluate)
 import System.Environment
 import System.CPUTime
 import System.Time
 import System.Random
 
+import qualified Data.Array.Parallel.Unlifted as U
+
 
 -- Time
 --
@@ -25,15 +33,33 @@ generatePoints n
     toPoints []        = []
     toPoints (x:y:pts) = Point x y : toPoints pts
 
+loadPoints :: String -> IO [Point]
+loadPoints file
+  = do
+      h <- openBinaryFile file ReadMode
+      upts <- U.hGet h
+      hClose h
+      convert (U.fsts upts) (U.snds upts)
+
+convert :: U.Array Double -> U.Array Double -> IO [Point]
+convert xs ys
+  = do
+      let pts = zipWith Point (U.toList xs) (U.toList ys)
+      evaluate $ nf pts
+      return pts
+
 
 -- Benchmark
 -- 
 
-data Point = Point Double Double
+data Point = Point !Double !Double
 data Line  = Line  Point Point
 
 instance Show Point where
   show (Point x y) = show (x, y)
+  
+nf (Point x y:xs) = x `seq` y `seq` nf xs
+nf []             = ()
 
 upper :: (a -> a -> Bool) -> [(a, b)] -> b
 upper above = snd . foldl1 pick
@@ -64,28 +90,64 @@ quickHull points
     minx = upper (<) xs
     maxx = upper (>) xs
 
-{-
-main = print $ quickHull [Point x y | (x, y) <- pts]
+
+-- Parallel version
+
+hsplitPar :: [Point] -> Line -> [Point]
+hsplitPar points line@(Line p1 p2)
+  | length packed < 2 = p1:packed
+  | otherwise         = let left  = hsplitPar packed (Line p1 pm)
+                            right = hsplitPar packed (Line pm p2)
+                        in
+                        right `par` 
+                        (left ++ right)
+  where
+    cross  = [ (distance p line, p) | p <- points ]
+    packed = [ p | (p, (c, _)) <- zip points cross, c > 0.0 ]
+
+    pm     = upper (>) cross
+
+quickHullPar :: [Point] -> [Point]
+quickHullPar [] = []
+quickHullPar points
+  = let left  = hsplitPar points (Line minx maxx)
+        right = hsplitPar points (Line maxx minx)
+    in
+    right `par`
+    (left ++ right)
   where
-    pts = [(3,3),(2,7),(0,0),(8,5), (4,6),(5,3),(9,6),(10,0)]
- -}
+    xs   = [ (x, p) | p@(Point x y) <- points ]
+    minx = upper (<) xs
+    maxx = upper (>) xs
+
+-- OBSERVATION: If we use nf on 'right' in 'quickHullPar' and 'hsplitPar' (and maybe even 
+--   'nf right `par` nf left `pseq` ...') the parallel GC takes a big hit and makes everything much
+--   slower.  (Keep in mind that even in the good case, this program spends 2/3 of its running time
+--   in the GC.)
+
+-- main
+--
 
 main :: IO ()
 main
   = do
-      [args1, args2] <- getArgs
+      [mode, args1, args2] <- getArgs
       let runs = read args1
-          n    = read args2
-
-      let pts  = generatePoints n
-      eval pts `seq` return ()
+      --     n    = read args2
+      -- 
+      -- let pts  = generatePoints n
+      -- eval pts `seq` return ()
+      pts <- loadPoints args2
       let {-# NOINLINE oneRun #-}       -- important to execute multiple runs
           oneRun pts = do 
                          t1 <- getTime
-                         let len = length $ quickHull pts
-                         len `seq` return ()
+                         let res = case mode of 
+                                     "seq" -> quickHull pts
+                                     "par" -> quickHullPar pts
+                                     _     -> error "mode must be 'seq' or 'par'"
+                         evaluate $ nf res
                          t2 <- getTime
-                         return (len, fromTime (t2 `minus` t1))
+                         return (length res, fromTime (t2 `minus` t1))
       results <- sequence (replicate runs (oneRun pts))
 
       let (lens, times) = unzip results
@@ -96,7 +158,4 @@ main
                              (sum cpus  `div` toInteger runs) ++ " " ++
                  showWallCPU (maximum walls) (maximum cpus)
   where
-    eval (Point x y:xs) = x `seq` y `seq` eval xs
-    eval []     = ()
-
     showWallCPU wall cpu = show wall ++"/" ++ show cpu
\ No newline at end of file