X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FPArr.hs;h=0b5154ec6d16ba2451d0469aed5042b5a1522c7f;hb=f42d88adb84299941a6be23fa73a9bb6ceeba475;hp=8ce448814d8bb2058e5171503353baed95e27ba4;hpb=ad2464d7646b2b0745615f4a23967444e23fea40;p=haskell-directory.git

diff --git a/GHC/PArr.hs b/GHC/PArr.hs
index 8ce4488..0b5154e 100644
--- a/GHC/PArr.hs
+++ b/GHC/PArr.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fparr #-}
+{-# OPTIONS_GHC -fparr -funbox-strict-fields #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -135,8 +135,9 @@ module GHC.PArr (
   fold1P,		-- :: (e -> e -> e) ->      [:e:] -> e
   permuteP,		-- :: [:Int:] -> [:e:] ->          [:e:]
   bpermuteP,		-- :: [:Int:] -> [:e:] ->          [:e:]
-  bpermuteDftP,		-- :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
+  dpermuteP,		-- :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
   crossP,		-- :: [:a:] -> [:b:] -> [:(a, b):]
+  crossMapP,		-- :: [:a:] -> (a -> [:b:]) -> [:(a, b):]
   indexOfP		-- :: (a -> Bool) -> [:a:] -> [:Int:]
 ) where
 
@@ -144,7 +145,7 @@ import Prelude
 
 import GHC.ST   ( ST(..), STRep, runST )
 import GHC.Exts	( Int#, Array#, Int(I#), MutableArray#, newArray#,
-		  unsafeFreezeArray#, indexArray#, writeArray# )
+		  unsafeFreezeArray#, indexArray#, writeArray#, (<#), (>=#) )
 
 infixl 9  !:
 infixr 5  +:+
@@ -216,7 +217,7 @@ scanlP     :: (a -> b -> a) -> a -> [:b:] -> [:a:]
 scanlP f z  = fst . loop (scanEFL (flip f)) z
 
 scanl1P        :: (a -> a -> a) -> [:a:] -> [:a:]
-acanl1P f [::]  = error "Prelude.scanl1P: empty array"
+scanl1P f [::]  = error "Prelude.scanl1P: empty array"
 scanl1P f a     = fst $ loopFromTo 1 (lengthP a - 1) (scanEFL f) (a!:0) a
 
 foldrP :: (a -> b -> b) -> b -> [:a:] -> b
@@ -245,7 +246,7 @@ takeP   :: Int -> [:a:] -> [:a:]
 takeP n  = sliceP 0 (n - 1)
 
 dropP     :: Int -> [:a:] -> [:a:]
-dropP n a  = sliceP (n - 1) (lengthP a - 1) a
+dropP n a  = sliceP n (lengthP a - 1) a
 
 splitAtP      :: Int -> [:a:] -> ([:a:],[:a:])
 splitAtP n xs  = (takeP n xs, dropP n xs)
@@ -297,7 +298,7 @@ sumP :: (Num a) => [:a:] -> a
 sumP  = foldP (+) 0
 
 productP :: (Num a) => [:a:] -> a
-productP  = foldP (*) 0
+productP  = foldP (*) 1
 
 maximumP      :: (Ord a) => [:a:] -> a
 maximumP [::]  = error "Prelude.maximumP: empty parallel array"
@@ -402,7 +403,7 @@ instance Read a => Read [:a:]  where
 -- Ideally, we would like `enumFromToP' and `enumFromThenToP' to be members of
 -- `Enum'.  On the other hand, we really do not want to change `Enum'.  Thus,
 -- for the moment, we hope that the compiler is sufficiently clever to
--- properly fuse the following definition.
+-- properly fuse the following definitions.
 
 enumFromToP	:: Enum a => a -> a -> [:a:]
 enumFromToP x y  = mapP toEnum (eftInt (fromEnum x) (fromEnum y))
@@ -414,7 +415,7 @@ enumFromThenToP x y z  =
   mapP toEnum (efttInt (fromEnum x) (fromEnum y) (fromEnum z))
   where
     efttInt x y z = scanlP (+) x $ 
-		      replicateP ((z - x + 1) `div` delta - 1) delta
+		      replicateP (abs (z - x) `div` abs delta + 1) delta
       where
        delta = y - x
 
@@ -457,7 +458,18 @@ fold1P  = foldl1P
 -- (EXPORTED)
 --
 permuteP       :: [:Int:] -> [:e:] -> [:e:]
-permuteP is es  = fst $ loop (mapEFL (es!:)) noAL is
+permuteP is es 
+  | isLen /= esLen = error "GHC.PArr: arguments must be of the same length"
+  | otherwise      = runST (do
+		       marr <- newArray isLen noElem
+		       permute marr is es
+		       mkPArr isLen marr)
+  where
+    noElem = error "GHC.PArr.permuteP: I do not exist!"
+	     -- unlike standard Haskell arrays, this value represents an
+	     -- internal error
+    isLen = lengthP is
+    esLen = lengthP es
 
 -- permute an array according to the back-permutation vector in the first
 -- argument (EXPORTED)
@@ -466,17 +478,32 @@ permuteP is es  = fst $ loop (mapEFL (es!:)) noAL is
 --   the result is undefined
 --
 bpermuteP       :: [:Int:] -> [:e:] -> [:e:]
-bpermuteP is es  = error "Prelude.bpermuteP: not implemented yet" -- FIXME
+bpermuteP is es  = fst $ loop (mapEFL (es!:)) noAL is
 
--- permute an array according to the back-permutation vector in the first
+-- permute an array according to the permutation vector in the first
 -- argument, which need not be surjective (EXPORTED)
 --
--- * any elements in the result that are not covered by the back-permutation
+-- * any elements in the result that are not covered by the permutation
 --   vector assume the value of the corresponding position of the third
 --   argument 
 --
-bpermuteDftP       :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
-bpermuteDftP is es  = error "Prelude.bpermuteDftP: not implemented yet"-- FIXME
+dpermuteP :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
+dpermuteP is es dft
+  | isLen /= esLen = error "GHC.PArr: arguments must be of the same length"
+  | otherwise      = runST (do
+		       marr <- newArray dftLen noElem
+		       trans 0 (isLen - 1) marr dft copyOne noAL
+		       permute marr is es
+		       mkPArr dftLen marr)
+  where
+    noElem = error "GHC.PArr.permuteP: I do not exist!"
+	     -- unlike standard Haskell arrays, this value represents an
+	     -- internal error
+    isLen  = lengthP is
+    esLen  = lengthP es
+    dftLen = lengthP dft
+
+    copyOne e _ = (Just e, noAL)
 
 -- computes the cross combination of two arrays (EXPORTED)
 --
@@ -506,6 +533,25 @@ crossP a1 a2  = let
 		zipP x1 x2
  -}
 
+-- |Compute a cross of an array and the arrays produced by the given function
+-- for the elements of the first array.
+--
+crossMapP :: [:a:] -> (a -> [:b:]) -> [:(a, b):]
+crossMapP a f = let
+		  bs   = mapP f a
+		  segd = mapP lengthP bs
+		  as   = zipWithP replicateP segd a
+	        in
+		zipP (concatP as) (concatP bs)
+
+{- The following may seem more straight forward, but the above is very cheap
+   with segmented arrays, as `mapP lengthP', `zipP', and `concatP' are
+   constant time, and `map f' uses the lifted version of `f'.
+
+crossMapP a f = concatP $ mapP (\x -> mapP ((,) x) (f x)) a
+
+ -}
+
 -- computes an index array for all elements of the second argument for which
 -- the predicate yields `True' (EXPORTED)
 --
@@ -566,11 +612,11 @@ loopFromTo from to mf start arr = runST (do
   arr       <- mkPArr n' marr
   return (arr, acc))
   where
-    noElem = error "PrelPArr.loopFromTo: I do not exist!"
+    noElem = error "GHC.PArr.loopFromTo: I do not exist!"
 	     -- unlike standard Haskell arrays, this value represents an
 	     -- internal error
 
--- actually loop body of `loop'
+-- actual loop body of `loop'
 --
 -- * for this to be really efficient, it has to be translated with the
 --   constructor specialisation phase "SpecConstr" switched on; as of GHC 5.03
@@ -597,6 +643,17 @@ trans from to marr arr mf start = trans' from 0 start
 					return $ marrOff + 1
                         trans' (arrOff + 1) marrOff' acc'
 
+-- Permute the given elements into the mutable array.
+--
+permute :: MPArr s e -> [:Int:] -> [:e:] -> ST s ()
+permute marr is es = perm 0
+  where
+    perm i
+      | i == n = return ()
+      | otherwise  = writeMPArr marr (is!:i) (es!:i) >> perm (i + 1)
+      where
+        n = lengthP is
+
 
 -- common patterns for using `loop'
 --
@@ -637,12 +694,21 @@ scanEFL f  = \e a -> (Just a, f e a)
 --
 indexPArr                       :: [:e:] -> Int -> e
 {-# INLINE indexPArr #-}
-indexPArr (PArr _ arr#) (I# i#)  = 
-  case indexArray# arr# i# of (# e #) -> e
+indexPArr (PArr n# arr#) (I# i#) 
+  | i# >=# 0# && i# <# n# =
+    case indexArray# arr# i# of (# e #) -> e
+  | otherwise = error $ "indexPArr: out of bounds parallel array index; " ++
+			"idx = " ++ show (I# i#) ++ ", arr len = "
+			++ show (I# n#)
 
 -- encapsulate writing into a mutable array into the `ST' monad
 --
 writeMPArr                           :: MPArr s e -> Int -> e -> ST s ()
 {-# INLINE writeMPArr #-}
-writeMPArr (MPArr _ marr#) (I# i#) e  = ST $ \s# ->
-  case writeArray# marr# i# e s# of s'# -> (# s'#, () #)
+writeMPArr (MPArr n# marr#) (I# i#) e 
+  | i# >=# 0# && i# <# n# =
+    ST $ \s# ->
+    case writeArray# marr# i# e s# of s'# -> (# s'#, () #)
+  | otherwise = error $ "writeMPArr: out of bounds parallel array index; " ++
+			"idx = " ++ show (I# i#) ++ ", arr len = "
+			++ show (I# n#)