dph-lifted-vseg: eliminate sharing in arrays during zipl
authorBen Lippmeier <benl@ouroborus.net>
Tue, 8 Nov 2011 09:55:51 +0000 (20:55 +1100)
committerBen Lippmeier <benl@ouroborus.net>
Wed, 9 Nov 2011 05:29:00 +0000 (16:29 +1100)
With lifted zip, we can't guarantee that the two arrays were created in the same way, so have to eliminate sharing via the vsegds before zipping the components.

dph-lifted-reference/Data/Array/Parallel/PArray.hs
dph-lifted-reference/dph-lifted-reference.cabal
dph-lifted-vseg/Data/Array/Parallel/PArray.hs
dph-lifted-vseg/Data/Array/Parallel/PArray/PData/Tuple.hs
dph-lifted-vseg/Data/Array/Parallel/PArray/PRepr/Base.hs
dph-lifted-vseg/Data/Array/Parallel/PArray/PRepr/Tuple.hs

index 00a0526..f927b36 100644 (file)
@@ -14,8 +14,14 @@ module Data.Array.Parallel.PArray
         -- * Projections
         , length,       lengthl
         , index,        indexl
-        , extract)
+        , extract
+        
+        -- * Pack and Combine
+        , pack,         packl
+        , packByTag
+        , combine2)
 where
+import Data.Array.Parallel.Base                 (Tag)
 import Data.Vector                              (Vector)
 import qualified Data.Array.Parallel.Unlifted   as U
 import qualified Data.Array.Parallel.Array      as A
@@ -109,8 +115,7 @@ replicatel = lift2 replicate
 replicates :: U.Segd -> PArray a -> PArray a
 replicates segd (PArray n# vec)
  | I# n# /= U.lengthSegd segd
- = die "replicates"  
-        $ unlines 
+ = die "replicates" $ unlines
         [ "segd length mismatch"
         , "  segd length  = " ++ show (U.lengthSegd segd)
         , "  array length = " ++ show (I# n#) ]
@@ -183,7 +188,53 @@ extract (PArray _ vec) start len@(I# len#)
         = PArray len# $ V.slice start len vec
 
 
+-- Pack and Combine -----------------------------------------------------------
+-- | Select the elements of an array that have their tag set to True.
+pack    :: PArray a -> PArray Bool -> PArray a
+pack (PArray n1# xs) (PArray n2# bs)
+ | I# n1# /= I# n2#
+ = die "pack" $ unlines
+        [ "array length mismatch"
+        , "  data  length = " ++ show (I# n1#)
+        , "  flags length = " ++ show (I# n2#) ]
+
+ | otherwise
+ = let  xs'      = V.ifilter (\i _ -> bs V.! i) xs
+        !(I# n') = V.length xs'
+   in   PArray n' xs'
 
+-- | Lifted pack.
+packl :: PArray (PArray a) -> PArray (PArray Bool) -> PArray (PArray a)
+packl   = lift2 pack
 
 
+-- | Filter an array based on some tags.
+packByTag :: PArray a -> U.Array Tag -> Tag -> PArray a
+packByTag (PArray n1# xs) tags tag
+ | I# n1# /= U.length tags
+ = die "packByTag" $ unlines
+        [ "array length mismatch"
+        , "  data  length = " ++ show (I# n1#)
+        , "  flags length = " ++ (show $ U.length tags) ]
 
+ | otherwise
+ = let  xs'      = V.ifilter (\i _ -> tags U.!: i == tag) xs
+        !(I# n') = V.length xs'
+   in   PArray n' xs'
+
+
+-- | Combine two arrays based on a selector.
+combine2 :: U.Sel2 -> PArray a -> PArray a -> PArray a
+combine2 tags (PArray n1# vec1) (PArray n2# vec2)
+ = let  
+        go [] [] [] = []
+        go (0 : bs) (x : xs) ys       = x : go bs xs ys
+        go (1 : bs) xs       (y : ys) = y : go bs xs ys
+        vec3    = V.fromList
+                $ go    (V.toList $ V.convert $ U.tagsSel2 tags)
+                        (V.toList vec1)
+                        (V.toList vec2)
+        !(I# n') = V.length vec3
+   
+    in  PArray n' vec3
index 824d581..07ec22a 100644 (file)
@@ -54,6 +54,9 @@ Library
         -funbox-strict-fields
         -fcpr-off
   
+  Exposed:
+        False
+
   Build-Depends:  
         base             == 4.4.*,
         ghc              == 7.*,
index b66adb4..54ce8ff 100644 (file)
@@ -78,13 +78,21 @@ import Prelude hiding
         
 import Debug.Trace
 
+-- Config ---------------------------------------------------------------------
+debugLiftedTrace        = False
+debugLiftedCompare      = False
+
+
 -- Tracing --------------------------------------------------------------------
 -- TODO: we could use this to trace the lengths of the vectors being used, 
 --       as well as the types that each opeartor is being called at.
 
 instance PA e => A.Array PArray e where
  length arr     = length arr
- index          = index
+
+ index (PArray _ pdata) ix
+        = indexPA pdata ix
+
  append         = append
 
  -- The toVector conversion used for testing is built by looking up every index
@@ -115,33 +123,69 @@ instance PA a => PprPhysical (Vector a) where
 -- TODO: shift this stuff to the reference implementation module.
 --       make the PArray constructor polymorphic
 -- | Compare a flat array against a reference
-withRef1 :: forall a. PA a => String -> R.PArray a -> PArray a -> PArray a
+withRef1 :: PA a 
+         => String
+         -> R.PArray a
+         -> PArray a
+         -> PArray a
+
 withRef1 name arrRef arrImpl
- = trace (T.render $ T.text name T.$$ pprpPA arrImpl)
- $ if (  valid arrImpl
-      && A.length arrRef == A.length arrImpl
-      && (V.and $ V.zipWith
-                similarPA
-                (A.toVectors1 arrRef) (A.toVectors1 arrImpl)))
-    then arrImpl
-    else error $ T.render $ T.vcat
-          [ T.text "withRef1: failure " T.<> T.text name
-          , T.nest 4 $ pprp  $ A.toVectors1 arrRef
-          , T.nest 4 $ pprpPA arrImpl ]
-
-
-withRef2 :: forall a. PA a => String -> R.PArray (R.PArray a) -> PArray (PArray a) -> PArray (PArray a)
+ = let  trace'
+         = if debugLiftedTrace  
+            then trace (T.render $ T.text " " 
+                        T.$$ T.text name 
+                        T.$$ (T.nest 8 $ pprpPA arrImpl))
+            else id    
+
+        resultOk
+         = valid arrImpl
+             && A.length arrRef == A.length arrImpl
+             && (V.and $ V.zipWith
+                  similarPA
+                  (A.toVectors1 arrRef) (A.toVectors1 arrImpl))
+              
+        resultFail
+         = error $ T.render $ T.vcat
+                [ T.text "withRef1: failure " T.<> T.text name
+                , T.nest 4 $ pprp  $ A.toVectors1 arrRef
+                , T.nest 4 $ pprpPA arrImpl ]
+
+   in   trace' (if debugLiftedCompare
+                 then (if resultOk then arrImpl else resultFail)
+                 else arrImpl)
+{-# INLINE withRef1 #-}
+
+
+withRef2 :: PA a 
+         => String 
+         -> R.PArray (R.PArray a)
+         -> PArray (PArray a)
+         -> PArray (PArray a)
+
 withRef2 name arrRef arrImpl
- = trace (T.render $ T.text name T.$$ pprpPA arrImpl)
- $ if (  valid arrImpl
-      && A.length arrRef == A.length arrImpl
-      && (V.and $ V.zipWith 
+ = let  trace'
+         = if debugLiftedTrace  
+            then trace (T.render $ T.text " " 
+                        T.$$ T.text name 
+                        T.$$ (T.nest 8 $ pprpPA arrImpl))
+            else id
+
+        resultOK
+         = valid arrImpl
+           && A.length arrRef == A.length arrImpl
+           && (V.and $ V.zipWith 
                 (\xs ys -> V.and $ V.zipWith similarPA xs ys)
-                (A.toVectors2 arrRef) (A.toVectors2 arrImpl)))
-    then arrImpl
-    else error $ T.render $ T.vcat
-          [ T.text "withRef2: failure " T.<> T.text name
-          , T.nest 4 $ pprpPA arrImpl ]
+                (A.toVectors2 arrRef) (A.toVectors2 arrImpl))
+        
+        resultFail
+         = error $ T.render $ T.vcat
+                [ T.text "withRef2: failure " T.<> T.text name
+                , T.nest 4 $ pprpPA arrImpl ]
+
+   in   trace' (if debugLiftedCompare
+                 then (if resultOK then arrImpl else resultFail)
+                 else arrImpl)
+{-# INLINE withRef2 #-}
 
 
 -- TODO: shift this stuff to the reference implementation module.
@@ -236,8 +280,7 @@ replicatel reps@(PArray n# (PInt lens)) arr@(PArray _ pdata)
 -- | O(sum lengths). Segmented replicate.
 replicates :: PA a => U.Segd -> PArray a -> PArray a
 replicates segd arr@(PArray _ pdata)
- = trace (T.render $ (T.text "FUCK" T.$$ (T.pprp segd) T.$$ (T.pprp arr)))
- $ withRef1 "replicates" (R.replicates segd (toRef1 arr))
+ = withRef1 "replicates" (R.replicates segd (toRef1 arr))
  $ let  !(I# n#) = U.elementsSegd segd
    in   PArray n# $ replicatesPA segd pdata
 {-# INLINE_PA replicates #-}
@@ -315,28 +358,29 @@ nestUSegd segd (PArray n# pdata)
 -- Projections  ---------------------------------------------------------------
 -- | Take the length of some arrays.
 lengthl :: PA a => PArray (PArray a) -> PArray Int
-lengthl (PArray n# (PNested vsegd _))
-        = PArray n# $ PInt $ U.takeLengthsOfVSegd vsegd
+lengthl arr@(PArray n# (PNested vsegd _))
+ = withRef1 "lengthl" (R.lengthl (toRef2 arr))
+ $ PArray n# $ PInt $ U.takeLengthsOfVSegd vsegd
 
 
 -- | O(1). Lookup a single element from the source array.
 index    :: PA a => PArray a -> Int -> a
 index (PArray _ arr) ix
       = indexPA arr ix
+ = indexPA arr ix
 {-# INLINE_PA index #-}
 
 
 -- | O(len indices). Lookup a several elements from several source arrays
 indexl    :: PA a => PArray (PArray a) -> PArray Int -> PArray a
 indexl (PArray n# darr) (PArray _ ixs)
       = PArray n# (indexlPA darr ixs)
+ = PArray n# (indexlPA darr ixs)
 {-# INLINE_PA indexl #-}
 
 
 -- | Extract a range of elements from an array.
 extract  :: PA a => PArray a -> Int -> Int -> PArray a
 extract (PArray _ arr) start len@(I# len#)
       = PArray len# (extractPA arr start len)
+ = PArray len# (extractPA arr start len)
 {-# INLINE_PA extract #-}
 
 
@@ -374,7 +418,7 @@ extracts' arrs (PArray _ (PInt sources)) (PArray _ (PInt starts)) (PArray _ (PIn
 --   Like `extract` but with the parameters in a different order.
 slice :: PA a => Int -> Int -> PArray a -> PArray a
 slice start len@(I# len#) (PArray _ darr)
       = PArray len# (extractPA darr start len)
+ = PArray len# (extractPA darr start len)
 {-# INLINE_PA slice #-}
 
 
@@ -383,7 +427,7 @@ slice start len@(I# len#) (PArray _ darr)
 --   have the same length.
 slicel :: PA a => PArray Int -> PArray Int -> PArray (PArray a) -> PArray (PArray a)
 slicel (PArray n# sliceStarts) (PArray _ sliceLens) (PArray _ darr)
       = PArray n# (slicelPD sliceStarts sliceLens darr)
+ = PArray n# (slicelPD sliceStarts sliceLens darr)
 {-# INLINE_PA slicel #-}
 
 
@@ -398,8 +442,9 @@ unsafeTakeSegd (PArray _ pdata)
 -- Pack and Combine -----------------------------------------------------------
 -- | Select the elements of an array that have their tag set to True.
 pack :: PA a => PArray a -> PArray Bool -> PArray a
-pack (PArray _ xs) (PArray _ (PBool sel2))
- = let  darr'           = packByTagPA xs (U.tagsSel2 sel2) 1
+pack arr@(PArray _ xs) flags@(PArray _ (PBool sel2))
+ = withRef1 "pack" (R.pack (toRef1 arr) (toRef1 flags))
+ $ let  darr'           = packByTagPA xs (U.tagsSel2 sel2) 1
 
         -- The selector knows how many elements are set to '1',
         -- so we can use this for the length of the resulting array.
@@ -410,13 +455,11 @@ pack (PArray _ xs) (PArray _ (PBool sel2))
 
 
 -- | Lifted pack.
---   Both data and tag arrays must have the same virtual segmentation structure, 
---   but this is not checked.
 packl :: PA a => PArray (PArray a) -> PArray (PArray Bool) -> PArray (PArray a)
-packl xss fss
- | PArray n# xdata@(PNested vsegd _)    <- xss
- , PArray _  fdata                      <- fss
= let  
+packl xss@(PArray n# xdata@(PNested vsegd _))
+      fss@(PArray _  fdata)
+ = withRef2 "packl" (R.packl (toRef2 xss) (toRef2 fss))
$ let  
         -- Demote the vsegd to get the virtual segmentation of the two arrays.
         -- The virtual segmentation of both must be the same, but this is not checked.
         segd            = U.demoteToSegdOfVSegd vsegd
@@ -441,8 +484,9 @@ packl xss fss
 
 -- | Filter an array based on some tags.
 packByTag :: PA a => PArray a -> U.Array Tag -> Tag -> PArray a
-packByTag (PArray _ darr) tags tag
- = let  darr'           = packByTagPA darr tags tag
+packByTag arr@(PArray _ darr) tags tag
+ = withRef1 "packByTag" (R.packByTag (toRef1 arr) tags tag)
+ $ let  darr'           = packByTagPA darr tags tag
         !(I# n#)        = lengthPA darr'
    in   PArray  n# darr'
 
@@ -450,9 +494,10 @@ packByTag (PArray _ darr) tags tag
 
 
 -- | Combine two arrays based on a selector.
-combine2  :: PA a => U.Sel2 -> PArray a -> PArray a -> PArray a
-combine2 sel (PArray _ darr1) (PArray _ darr2)
- = let  darr'           = combine2PA sel darr1 darr2
+combine2  :: forall a. PA a => U.Sel2 -> PArray a -> PArray a -> PArray a
+combine2 sel arr1@(PArray _ darr1) arr2@(PArray _ darr2)
+ = withRef1 "combine2" (R.combine2 sel (toRef1 arr1) (toRef1 arr2))
+ $ let  darr'           = combine2PA sel darr1 darr2
         !(I# n#)        = lengthPA darr'
    in   PArray  n# darr'
 {-# INLINE_PA combine2 #-}
@@ -473,6 +518,7 @@ toVector (PArray _ arr)
         = toVectorPA arr
 {-# INLINE_PA toVector #-}
 
+
 -- | Convert a list to a `PArray`.
 fromList :: PA a => [a] -> PArray a
 fromList xx
index ac11f5f..12800b4 100644 (file)
@@ -3,7 +3,7 @@
 module Data.Array.Parallel.PArray.PData.Tuple 
         ( PData(..),    PDatas(..)
         , zip,          zipPD
-        , zipl,         ziplPD
+        ,               ziplPR
         , unzip,        unzipPD
         , unzipl,       unziplPD)
 where
@@ -15,6 +15,9 @@ import GHC.Exts
 import Prelude hiding (zip, unzip)
 import qualified Data.Vector                    as V
 import qualified Prelude                        as P
+import Debug.Trace
+import qualified Data.Array.Parallel.Pretty     as T
+import qualified Data.Array.Parallel.Unlifted   as U
 
 -------------------------------------------------------------------------------
 data instance PData (a, b)
@@ -199,10 +202,14 @@ zipPD   = PTuple2
 
 
 -- | Lifted zip.
-ziplPD   :: PData (PArray a) -> PData (PArray b) -> PData (PArray (a, b))
-ziplPD (PNested vsegd pdatas1) (PNested _ pdatas2)
-        = PNested vsegd (PTuple2s pdatas1 pdatas2)
-{-# INLINE_PA ziplPD #-}
+ziplPR   :: (PR a, PR b) => PData (PArray a) -> PData (PArray b) -> PData (PArray (a, b))
+ziplPR arr1@(PNested vsegd1 pdatas1) arr2@(PNested vsegd2 pdatas2)
+ = let  (segd1, pdata1) = unsafeFlattenPR arr1
+        (_,     pdata2) = unsafeFlattenPR arr2
+   in   PNested (U.promoteSegdToVSegd segd1)
+                (PTuple2s (singletondPR pdata1) (singletondPR pdata2))
+
+{-# INLINE_PA ziplPR #-}
 
 
 -- | O(1). Unzip an array of pairs into a pair of arrays.
@@ -230,12 +237,6 @@ zip (PArray n# pdata1) (PArray _ pdata2)
 {-# INLINE_PA zip #-}
 
 
--- | Lifted zip.
-zipl :: PArray (PArray a) -> PArray (PArray b) -> PArray (PArray (a, b))
-zipl (PArray n# xs) (PArray _ ys)
-        = PArray n# $ ziplPD xs ys
-
-
 -- | O(1). Unzip an array of pairs into a pair of arrays.
 unzip :: PArray (a, b) -> (PArray a, PArray b)
 unzip (PArray n# (PTuple2 xs ys))
index d82bb08..adb7a93 100644 (file)
@@ -76,8 +76,8 @@ class PR (PRepr a) => PA a where
   toArrPReprs           :: PDatas a             -> PDatas (PRepr a)
   fromArrPReprs         :: PDatas (PRepr a)     -> PDatas a
 
-  toNestedArrPRepr      :: PData (PArray a)     -> PData (PArray (PRepr a))
-
+  toNestedArrPRepr      :: PData (PArray a)         -> PData (PArray (PRepr a))
+  fromNestedArrPRepr    :: PData (PArray (PRepr a)) -> PData (PArray a)
 
 -- PD Wrappers ----------------------------------------------------------------
 --  These wrappers work on (PData a) arrays when we know the element type 'a'
index 7e18037..cde6ebf 100644 (file)
@@ -2,7 +2,10 @@
 
 -- | PRepr instance for tuples
 --   and PD wrappers for other functions defined in D.A.P.PArray.PData.Tuple.
-module Data.Array.Parallel.PArray.PRepr.Tuple where
+module Data.Array.Parallel.PArray.PRepr.Tuple
+        ( PRepr(..)
+        , zipl)
+where
 import Data.Array.Parallel.PArray.Types
 import Data.Array.Parallel.PArray.PRepr.Base
 import Data.Array.Parallel.PArray.PData.Base
@@ -45,4 +48,24 @@ instance (PA a, PA b) => PA (a,b) where
   {-# INLINE_PA toNestedArrPRepr #-}
   toNestedArrPRepr (PNested vsegd (PTuple2s as bs))
         = PNested vsegd (PTuple2s (PWraps as) (PWraps bs))
-        
+
+
+-- | Lifted zip.
+zipl    :: (PA a, PA b)
+        => PArray (PArray a) -> PArray (PArray b) -> PArray (PArray (a, b))
+zipl (PArray n# xs) (PArray _ ys)
+        = PArray n# $ ziplPA xs ys
+
+
+ziplPA  :: (PA a, PA b) 
+        => PData (PArray a) -> PData (PArray b) -> PData (PArray (a, b))
+ziplPA xs ys
+ = let  PNested vsegd (PTuple2s xs' ys')
+         = ziplPR (toNestedArrPRepr xs)
+                  (toNestedArrPRepr ys)
+
+   in   PNested vsegd (PTuple2s   
+                        (fromArrPReprs xs')
+                        (fromArrPReprs ys'))
+
+