GHC/PArr.hs

   1 {-# OPTIONS_GHC -funbox-strict-fields #-}
   2 {-# LANGUAGE PArr #-}
   3
   4 -----------------------------------------------------------------------------
   5 -- |
   6 -- Module      :  GHC.PArr
   7 -- Copyright   :  (c) 2001-2002 Manuel M T Chakravarty & Gabriele Keller
   8 -- License     :  see libraries/base/LICENSE
   9 --
  10 -- Maintainer  :  Manuel M. T. Chakravarty <chak@cse.unsw.edu.au>
  11 -- Stability   :  internal
  12 -- Portability :  non-portable (GHC Extensions)
  13 --
  14 --  Basic implementation of Parallel Arrays.
  15 --
  16 --  This module has two functions: (1) It defines the interface to the
  17 --  parallel array extension of the Prelude and (2) it provides a vanilla
  18 --  implementation of parallel arrays that does not require to flatten the
  19 --  array code.  The implementation is not very optimised.
  20 --
  21 --- DOCU ----------------------------------------------------------------------
  22 --
  23 --  Language: Haskell 98 plus unboxed values and parallel arrays
  24 --
  25 --  The semantic difference between standard Haskell arrays (aka "lazy
  26 --  arrays") and parallel arrays (aka "strict arrays") is that the evaluation
  27 --  of two different elements of a lazy array is independent, whereas in a
  28 --  strict array either non or all elements are evaluated.  In other words,
  29 --  when a parallel array is evaluated to WHNF, all its elements will be
  30 --  evaluated to WHNF.  The name parallel array indicates that all array
  31 --  elements may, in general, be evaluated to WHNF in parallel without any
  32 --  need to resort to speculative evaluation.  This parallel evaluation
  33 --  semantics is also beneficial in the sequential case, as it facilitates
  34 --  loop-based array processing as known from classic array-based languages,
  35 --  such as Fortran.
  36 --
  37 --  The interface of this module is essentially a variant of the list
  38 --  component of the Prelude, but also includes some functions (such as
  39 --  permutations) that are not provided for lists.  The following list
  40 --  operations are not supported on parallel arrays, as they would require the
  41 --  availability of infinite parallel arrays: `iterate', `repeat', and `cycle'.
  42 --
  43 --  The current implementation is quite simple and entirely based on boxed
  44 --  arrays.  One disadvantage of boxed arrays is that they require to
  45 --  immediately initialise all newly allocated arrays with an error thunk to
  46 --  keep the garbage collector happy, even if it is guaranteed that the array
  47 --  is fully initialised with different values before passing over the
  48 --  user-visible interface boundary.  Currently, no effort is made to use
  49 --  raw memory copy operations to speed things up.
  50 --
  51 --- TODO ----------------------------------------------------------------------
  52 --
  53 --  * We probably want a standard library `PArray' in addition to the prelude
  54 --    extension in the same way as the standard library `List' complements the
  55 --    list functions from the prelude.
  56 --
  57 --  * Currently, functions that emphasis the constructor-based definition of
  58 --    lists (such as, head, last, tail, and init) are not supported.
  59 --
  60 --    Is it worthwhile to support the string processing functions lines,
  61 --    words, unlines, and unwords?  (Currently, they are not implemented.)
  62 --
  63 --    It can, however, be argued that it would be worthwhile to include them
  64 --    for completeness' sake; maybe only in the standard library `PArray'.
  65 --
  66 --  * Prescans are often more useful for array programming than scans.  Shall
  67 --    we include them into the Prelude or the library?
  68 --
  69 --  * Due to the use of the iterator `loop', we could define some fusion rules
  70 --    in this module.
  71 --
  72 --  * We might want to add bounds checks that can be deactivated.
  73 --
  74
  75 module GHC.PArr (
  76   -- [::],              -- Built-in syntax
  77
  78   mapP,                 -- :: (a -> b) -> [:a:] -> [:b:]
  79   (+:+),                -- :: [:a:] -> [:a:] -> [:a:]
  80   filterP,              -- :: (a -> Bool) -> [:a:] -> [:a:]
  81   concatP,              -- :: [:[:a:]:] -> [:a:]
  82   concatMapP,           -- :: (a -> [:b:]) -> [:a:] -> [:b:]
  83 --  head, last, tail, init,   -- it's not wise to use them on arrays
  84   nullP,                -- :: [:a:] -> Bool
  85   lengthP,              -- :: [:a:] -> Int
  86   (!:),                 -- :: [:a:] -> Int -> a
  87   foldlP,               -- :: (a -> b -> a) -> a -> [:b:] -> a
  88   foldl1P,              -- :: (a -> a -> a) ->      [:a:] -> a
  89   scanlP,               -- :: (a -> b -> a) -> a -> [:b:] -> [:a:]
  90   scanl1P,              -- :: (a -> a -> a) ->      [:a:] -> [:a:]
  91   foldrP,               -- :: (a -> b -> b) -> b -> [:a:] -> b
  92   foldr1P,              -- :: (a -> a -> a) ->      [:a:] -> a
  93   scanrP,               -- :: (a -> b -> b) -> b -> [:a:] -> [:b:]
  94   scanr1P,              -- :: (a -> a -> a) ->      [:a:] -> [:a:]
  95 --  iterate, repeat,          -- parallel arrays must be finite
  96   singletonP,           -- :: a -> [:a:]
  97   emptyP,               -- :: [:a:]
  98   replicateP,           -- :: Int -> a -> [:a:]
  99 --  cycle,                    -- parallel arrays must be finite
 100   takeP,                -- :: Int -> [:a:] -> [:a:]
 101   dropP,                -- :: Int -> [:a:] -> [:a:]
 102   splitAtP,             -- :: Int -> [:a:] -> ([:a:],[:a:])
 103   takeWhileP,           -- :: (a -> Bool) -> [:a:] -> [:a:]
 104   dropWhileP,           -- :: (a -> Bool) -> [:a:] -> [:a:]
 105   spanP,                -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
 106   breakP,               -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
 107 --  lines, words, unlines, unwords,  -- is string processing really needed
 108   reverseP,             -- :: [:a:] -> [:a:]
 109   andP,                 -- :: [:Bool:] -> Bool
 110   orP,                  -- :: [:Bool:] -> Bool
 111   anyP,                 -- :: (a -> Bool) -> [:a:] -> Bool
 112   allP,                 -- :: (a -> Bool) -> [:a:] -> Bool
 113   elemP,                -- :: (Eq a) => a -> [:a:] -> Bool
 114   notElemP,             -- :: (Eq a) => a -> [:a:] -> Bool
 115   lookupP,              -- :: (Eq a) => a -> [:(a, b):] -> Maybe b
 116   sumP,                 -- :: (Num a) => [:a:] -> a
 117   productP,             -- :: (Num a) => [:a:] -> a
 118   maximumP,             -- :: (Ord a) => [:a:] -> a
 119   minimumP,             -- :: (Ord a) => [:a:] -> a
 120   zipP,                 -- :: [:a:] -> [:b:]          -> [:(a, b)   :]
 121   zip3P,                -- :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):]
 122   zipWithP,             -- :: (a -> b -> c)      -> [:a:] -> [:b:] -> [:c:]
 123   zipWith3P,            -- :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:]
 124   unzipP,               -- :: [:(a, b)   :] -> ([:a:], [:b:])
 125   unzip3P,              -- :: [:(a, b, c):] -> ([:a:], [:b:], [:c:])
 126
 127   -- overloaded functions
 128   --
 129   enumFromToP,          -- :: Enum a => a -> a      -> [:a:]
 130   enumFromThenToP,      -- :: Enum a => a -> a -> a -> [:a:]
 131
 132   -- the following functions are not available on lists
 133   --
 134   toP,                  -- :: [a] -> [:a:]
 135   fromP,                -- :: [:a:] -> [a]
 136   sliceP,               -- :: Int -> Int -> [:e:] -> [:e:]
 137   foldP,                -- :: (e -> e -> e) -> e -> [:e:] -> e
 138   fold1P,               -- :: (e -> e -> e) ->      [:e:] -> e
 139   permuteP,             -- :: [:Int:] -> [:e:] ->          [:e:]
 140   bpermuteP,            -- :: [:Int:] -> [:e:] ->          [:e:]
 141   dpermuteP,            -- :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
 142   crossP,               -- :: [:a:] -> [:b:] -> [:(a, b):]
 143   crossMapP,            -- :: [:a:] -> (a -> [:b:]) -> [:(a, b):]
 144   indexOfP              -- :: (a -> Bool) -> [:a:] -> [:Int:]
 145 ) where
 146
 147 #ifndef __HADDOCK__
 148
 149 import Prelude
 150
 151 import GHC.ST   ( ST(..), runST )
 152 import GHC.Exts ( Int#, Array#, Int(I#), MutableArray#, newArray#,
 153                   unsafeFreezeArray#, indexArray#, writeArray#, (<#), (>=#) )
 154
 155 infixl 9  !:
 156 infixr 5  +:+
 157 infix  4  `elemP`, `notElemP`
 158
 159
 160 -- representation of parallel arrays
 161 -- ---------------------------------
 162
 163 -- this rather straight forward implementation maps parallel arrays to the
 164 -- internal representation used for standard Haskell arrays in GHC's Prelude
 165 -- (EXPORTED ABSTRACTLY)
 166 --
 167 -- * This definition *must* be kept in sync with `TysWiredIn.parrTyCon'!
 168 --
 169 data [::] e = PArr Int# (Array# e)
 170
 171
 172 -- exported operations on parallel arrays
 173 -- --------------------------------------
 174
 175 -- operations corresponding to list operations
 176 --
 177
 178 mapP   :: (a -> b) -> [:a:] -> [:b:]
 179 mapP f  = fst . loop (mapEFL f) noAL
 180
 181 (+:+)     :: [:a:] -> [:a:] -> [:a:]
 182 a1 +:+ a2  = fst $ loop (mapEFL sel) noAL (enumFromToP 0 (len1 + len2 - 1))
 183                        -- we can't use the [:x..y:] form here for tedious
 184                        -- reasons to do with the typechecker and the fact that
 185                        -- `enumFromToP' is defined in the same module
 186              where
 187                len1 = lengthP a1
 188                len2 = lengthP a2
 189                --
 190                sel i | i < len1  = a1!:i
 191                      | otherwise = a2!:(i - len1)
 192
 193 filterP   :: (a -> Bool) -> [:a:] -> [:a:]
 194 filterP p  = fst . loop (filterEFL p) noAL
 195
 196 concatP     :: [:[:a:]:] -> [:a:]
 197 concatP xss  = foldlP (+:+) [::] xss
 198
 199 concatMapP   :: (a -> [:b:]) -> [:a:] -> [:b:]
 200 concatMapP f  = concatP . mapP f
 201
 202 --  head, last, tail, init,   -- it's not wise to use them on arrays
 203
 204 nullP      :: [:a:] -> Bool
 205 nullP [::]  = True
 206 nullP _     = False
 207
 208 lengthP             :: [:a:] -> Int
 209 lengthP (PArr n# _)  = I# n#
 210
 211 (!:) :: [:a:] -> Int -> a
 212 (!:)  = indexPArr
 213
 214 foldlP     :: (a -> b -> a) -> a -> [:b:] -> a
 215 foldlP f z  = snd . loop (foldEFL (flip f)) z
 216
 217 foldl1P        :: (a -> a -> a) -> [:a:] -> a
 218 foldl1P f [::]  = error "Prelude.foldl1P: empty array"
 219 foldl1P f a     = snd $ loopFromTo 1 (lengthP a - 1) (foldEFL f) (a!:0) a
 220
 221 scanlP     :: (a -> b -> a) -> a -> [:b:] -> [:a:]
 222 scanlP f z  = fst . loop (scanEFL (flip f)) z
 223
 224 scanl1P        :: (a -> a -> a) -> [:a:] -> [:a:]
 225 scanl1P f [::]  = error "Prelude.scanl1P: empty array"
 226 scanl1P f a     = fst $ loopFromTo 1 (lengthP a - 1) (scanEFL f) (a!:0) a
 227
 228 foldrP :: (a -> b -> b) -> b -> [:a:] -> b
 229 foldrP  = error "Prelude.foldrP: not implemented yet" -- FIXME
 230
 231 foldr1P :: (a -> a -> a) -> [:a:] -> a
 232 foldr1P  = error "Prelude.foldr1P: not implemented yet" -- FIXME
 233
 234 scanrP :: (a -> b -> b) -> b -> [:a:] -> [:b:]
 235 scanrP  = error "Prelude.scanrP: not implemented yet" -- FIXME
 236
 237 scanr1P :: (a -> a -> a) -> [:a:] -> [:a:]
 238 scanr1P  = error "Prelude.scanr1P: not implemented yet" -- FIXME
 239
 240 --  iterate, repeat           -- parallel arrays must be finite
 241
 242 singletonP             :: a -> [:a:]
 243 {-# INLINE singletonP #-}
 244 singletonP e = replicateP 1 e
 245
 246 emptyP:: [:a:]
 247 {- NOINLINE emptyP #-}
 248 emptyP = replicateP 0 undefined
 249
 250
 251 replicateP             :: Int -> a -> [:a:]
 252 {-# INLINE replicateP #-}
 253 replicateP n e  = runST (do
 254   marr# <- newArray n e
 255   mkPArr n marr#)
 256
 257 --  cycle                     -- parallel arrays must be finite
 258
 259 takeP   :: Int -> [:a:] -> [:a:]
 260 takeP n  = sliceP 0 (n - 1)
 261
 262 dropP     :: Int -> [:a:] -> [:a:]
 263 dropP n a  = sliceP n (lengthP a - 1) a
 264
 265 splitAtP      :: Int -> [:a:] -> ([:a:],[:a:])
 266 splitAtP n xs  = (takeP n xs, dropP n xs)
 267
 268 takeWhileP :: (a -> Bool) -> [:a:] -> [:a:]
 269 takeWhileP  = error "Prelude.takeWhileP: not implemented yet" -- FIXME
 270
 271 dropWhileP :: (a -> Bool) -> [:a:] -> [:a:]
 272 dropWhileP  = error "Prelude.dropWhileP: not implemented yet" -- FIXME
 273
 274 spanP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
 275 spanP  = error "Prelude.spanP: not implemented yet" -- FIXME
 276
 277 breakP   :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
 278 breakP p  = spanP (not . p)
 279
 280 --  lines, words, unlines, unwords,  -- is string processing really needed
 281
 282 reverseP   :: [:a:] -> [:a:]
 283 reverseP a  = permuteP (enumFromThenToP (len - 1) (len - 2) 0) a
 284                        -- we can't use the [:x, y..z:] form here for tedious
 285                        -- reasons to do with the typechecker and the fact that
 286                        -- `enumFromThenToP' is defined in the same module
 287               where
 288                 len = lengthP a
 289
 290 andP :: [:Bool:] -> Bool
 291 andP  = foldP (&&) True
 292
 293 orP :: [:Bool:] -> Bool
 294 orP  = foldP (||) True
 295
 296 anyP   :: (a -> Bool) -> [:a:] -> Bool
 297 anyP p  = orP . mapP p
 298
 299 allP :: (a -> Bool) -> [:a:] -> Bool
 300 allP p  = andP . mapP p
 301
 302 elemP   :: (Eq a) => a -> [:a:] -> Bool
 303 elemP x  = anyP (== x)
 304
 305 notElemP   :: (Eq a) => a -> [:a:] -> Bool
 306 notElemP x  = allP (/= x)
 307
 308 lookupP :: (Eq a) => a -> [:(a, b):] -> Maybe b
 309 lookupP  = error "Prelude.lookupP: not implemented yet" -- FIXME
 310
 311 sumP :: (Num a) => [:a:] -> a
 312 sumP  = foldP (+) 0
 313
 314 productP :: (Num a) => [:a:] -> a
 315 productP  = foldP (*) 1
 316
 317 maximumP      :: (Ord a) => [:a:] -> a
 318 maximumP [::]  = error "Prelude.maximumP: empty parallel array"
 319 maximumP xs    = fold1P max xs
 320
 321 minimumP :: (Ord a) => [:a:] -> a
 322 minimumP [::]  = error "Prelude.minimumP: empty parallel array"
 323 minimumP xs    = fold1P min xs
 324
 325 zipP :: [:a:] -> [:b:] -> [:(a, b):]
 326 zipP  = zipWithP (,)
 327
 328 zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):]
 329 zip3P  = zipWith3P (,,)
 330
 331 zipWithP         :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:]
 332 zipWithP f a1 a2  = let
 333                       len1 = lengthP a1
 334                       len2 = lengthP a2
 335                       len  = len1 `min` len2
 336                     in
 337                     fst $ loopFromTo 0 (len - 1) combine 0 a1
 338                     where
 339                       combine e1 i = (Just $ f e1 (a2!:i), i + 1)
 340
 341 zipWith3P :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:]
 342 zipWith3P f a1 a2 a3 = let
 343                         len1 = lengthP a1
 344                         len2 = lengthP a2
 345                         len3 = lengthP a3
 346                         len  = len1 `min` len2 `min` len3
 347                       in
 348                       fst $ loopFromTo 0 (len - 1) combine 0 a1
 349                       where
 350                         combine e1 i = (Just $ f e1 (a2!:i) (a3!:i), i + 1)
 351
 352 unzipP   :: [:(a, b):] -> ([:a:], [:b:])
 353 unzipP a  = (fst $ loop (mapEFL fst) noAL a, fst $ loop (mapEFL snd) noAL a)
 354 -- FIXME: these two functions should be optimised using a tupled custom loop
 355 unzip3P   :: [:(a, b, c):] -> ([:a:], [:b:], [:c:])
 356 unzip3P a  = (fst $ loop (mapEFL fst3) noAL a,
 357               fst $ loop (mapEFL snd3) noAL a,
 358               fst $ loop (mapEFL trd3) noAL a)
 359              where
 360                fst3 (a, _, _) = a
 361                snd3 (_, b, _) = b
 362                trd3 (_, _, c) = c
 363
 364 -- instances
 365 --
 366
 367 instance Eq a => Eq [:a:] where
 368   a1 == a2 | lengthP a1 == lengthP a2 = andP (zipWithP (==) a1 a2)
 369            | otherwise                = False
 370
 371 instance Ord a => Ord [:a:] where
 372   compare a1 a2 = case foldlP combineOrdering EQ (zipWithP compare a1 a2) of
 373                     EQ | lengthP a1 == lengthP a2 -> EQ
 374                        | lengthP a1 <  lengthP a2 -> LT
 375                        | otherwise                -> GT
 376                   where
 377                     combineOrdering EQ    EQ    = EQ
 378                     combineOrdering EQ    other = other
 379                     combineOrdering other _     = other
 380
 381 instance Functor [::] where
 382   fmap = mapP
 383
 384 instance Monad [::] where
 385   m >>= k  = foldrP ((+:+) . k      ) [::] m
 386   m >>  k  = foldrP ((+:+) . const k) [::] m
 387   return x = [:x:]
 388   fail _   = [::]
 389
 390 instance Show a => Show [:a:]  where
 391   showsPrec _  = showPArr . fromP
 392     where
 393       showPArr []     s = "[::]" ++ s
 394       showPArr (x:xs) s = "[:" ++ shows x (showPArr' xs s)
 395
 396       showPArr' []     s = ":]" ++ s
 397       showPArr' (y:ys) s = ',' : shows y (showPArr' ys s)
 398
 399 instance Read a => Read [:a:]  where
 400   readsPrec _ a = [(toP v, rest) | (v, rest) <- readPArr a]
 401     where
 402       readPArr = readParen False (\r -> do
 403                                           ("[:",s) <- lex r
 404                                           readPArr1 s)
 405       readPArr1 s =
 406         (do { (":]", t) <- lex s; return ([], t) }) ++
 407         (do { (x, t) <- reads s; (xs, u) <- readPArr2 t; return (x:xs, u) })
 408
 409       readPArr2 s =
 410         (do { (":]", t) <- lex s; return ([], t) }) ++
 411         (do { (",", t) <- lex s; (x, u) <- reads t; (xs, v) <- readPArr2 u;
 412               return (x:xs, v) })
 413
 414 -- overloaded functions
 415 --
 416
 417 -- Ideally, we would like `enumFromToP' and `enumFromThenToP' to be members of
 418 -- `Enum'.  On the other hand, we really do not want to change `Enum'.  Thus,
 419 -- for the moment, we hope that the compiler is sufficiently clever to
 420 -- properly fuse the following definitions.
 421
 422 enumFromToP     :: Enum a => a -> a -> [:a:]
 423 enumFromToP x y  = mapP toEnum (eftInt (fromEnum x) (fromEnum y))
 424   where
 425     eftInt x y = scanlP (+) x $ replicateP (y - x + 1) 1
 426
 427 enumFromThenToP       :: Enum a => a -> a -> a -> [:a:]
 428 enumFromThenToP x y z  =
 429   mapP toEnum (efttInt (fromEnum x) (fromEnum y) (fromEnum z))
 430   where
 431     efttInt x y z = scanlP (+) x $
 432                       replicateP (abs (z - x) `div` abs delta + 1) delta
 433       where
 434        delta = y - x
 435
 436 -- the following functions are not available on lists
 437 --
 438
 439 -- create an array from a list (EXPORTED)
 440 --
 441 toP   :: [a] -> [:a:]
 442 toP l  = fst $ loop store l (replicateP (length l) ())
 443          where
 444            store _ (x:xs) = (Just x, xs)
 445
 446 -- convert an array to a list (EXPORTED)
 447 --
 448 fromP   :: [:a:] -> [a]
 449 fromP a  = [a!:i | i <- [0..lengthP a - 1]]
 450
 451 -- cut a subarray out of an array (EXPORTED)
 452 --
 453 sliceP :: Int -> Int -> [:e:] -> [:e:]
 454 sliceP from to a =
 455   fst $ loopFromTo (0 `max` from) (to `min` (lengthP a - 1)) (mapEFL id) noAL a
 456
 457 -- parallel folding (EXPORTED)
 458 --
 459 -- * the first argument must be associative; otherwise, the result is undefined
 460 --
 461 foldP :: (e -> e -> e) -> e -> [:e:] -> e
 462 foldP  = foldlP
 463
 464 -- parallel folding without explicit neutral (EXPORTED)
 465 --
 466 -- * the first argument must be associative; otherwise, the result is undefined
 467 --
 468 fold1P :: (e -> e -> e) -> [:e:] -> e
 469 fold1P  = foldl1P
 470
 471 -- permute an array according to the permutation vector in the first argument
 472 -- (EXPORTED)
 473 --
 474 permuteP       :: [:Int:] -> [:e:] -> [:e:]
 475 permuteP is es
 476   | isLen /= esLen = error "GHC.PArr: arguments must be of the same length"
 477   | otherwise      = runST (do
 478                        marr <- newArray isLen noElem
 479                        permute marr is es
 480                        mkPArr isLen marr)
 481   where
 482     noElem = error "GHC.PArr.permuteP: I do not exist!"
 483              -- unlike standard Haskell arrays, this value represents an
 484              -- internal error
 485     isLen = lengthP is
 486     esLen = lengthP es
 487
 488 -- permute an array according to the back-permutation vector in the first
 489 -- argument (EXPORTED)
 490 --
 491 -- * the permutation vector must represent a surjective function; otherwise,
 492 --   the result is undefined
 493 --
 494 bpermuteP       :: [:Int:] -> [:e:] -> [:e:]
 495 bpermuteP is es  = fst $ loop (mapEFL (es!:)) noAL is
 496
 497 -- permute an array according to the permutation vector in the first
 498 -- argument, which need not be surjective (EXPORTED)
 499 --
 500 -- * any elements in the result that are not covered by the permutation
 501 --   vector assume the value of the corresponding position of the third
 502 --   argument
 503 --
 504 dpermuteP :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
 505 dpermuteP is es dft
 506   | isLen /= esLen = error "GHC.PArr: arguments must be of the same length"
 507   | otherwise      = runST (do
 508                        marr <- newArray dftLen noElem
 509                        trans 0 (isLen - 1) marr dft copyOne noAL
 510                        permute marr is es
 511                        mkPArr dftLen marr)
 512   where
 513     noElem = error "GHC.PArr.permuteP: I do not exist!"
 514              -- unlike standard Haskell arrays, this value represents an
 515              -- internal error
 516     isLen  = lengthP is
 517     esLen  = lengthP es
 518     dftLen = lengthP dft
 519
 520     copyOne e _ = (Just e, noAL)
 521
 522 -- computes the cross combination of two arrays (EXPORTED)
 523 --
 524 crossP       :: [:a:] -> [:b:] -> [:(a, b):]
 525 crossP a1 a2  = fst $ loop combine (0, 0) $ replicateP len ()
 526                 where
 527                   len1 = lengthP a1
 528                   len2 = lengthP a2
 529                   len  = len1 * len2
 530                   --
 531                   combine _ (i, j) = (Just $ (a1!:i, a2!:j), next)
 532                                      where
 533                                        next | (i + 1) == len1 = (0    , j + 1)
 534                                             | otherwise       = (i + 1, j)
 535
 536 {- An alternative implementation
 537    * The one above is certainly better for flattened code, but here where we
 538      are handling boxed arrays, the trade off is less clear.  However, I
 539      think, the above one is still better.
 540
 541 crossP a1 a2  = let
 542                   len1 = lengthP a1
 543                   len2 = lengthP a2
 544                   x1   = concatP $ mapP (replicateP len2) a1
 545                   x2   = concatP $ replicateP len1 a2
 546                 in
 547                 zipP x1 x2
 548  -}
 549
 550 -- |Compute a cross of an array and the arrays produced by the given function
 551 -- for the elements of the first array.
 552 --
 553 crossMapP :: [:a:] -> (a -> [:b:]) -> [:(a, b):]
 554 crossMapP a f = let
 555                   bs   = mapP f a
 556                   segd = mapP lengthP bs
 557                   as   = zipWithP replicateP segd a
 558                 in
 559                 zipP (concatP as) (concatP bs)
 560
 561 {- The following may seem more straight forward, but the above is very cheap
 562    with segmented arrays, as `mapP lengthP', `zipP', and `concatP' are
 563    constant time, and `map f' uses the lifted version of `f'.
 564
 565 crossMapP a f = concatP $ mapP (\x -> mapP ((,) x) (f x)) a
 566
 567  -}
 568
 569 -- computes an index array for all elements of the second argument for which
 570 -- the predicate yields `True' (EXPORTED)
 571 --
 572 indexOfP     :: (a -> Bool) -> [:a:] -> [:Int:]
 573 indexOfP p a  = fst $ loop calcIdx 0 a
 574                 where
 575                   calcIdx e idx | p e       = (Just idx, idx + 1)
 576                                 | otherwise = (Nothing , idx    )
 577
 578
 579 -- auxiliary functions
 580 -- -------------------
 581
 582 -- internally used mutable boxed arrays
 583 --
 584 data MPArr s e = MPArr Int# (MutableArray# s e)
 585
 586 -- allocate a new mutable array that is pre-initialised with a given value
 587 --
 588 newArray             :: Int -> e -> ST s (MPArr s e)
 589 {-# INLINE newArray #-}
 590 newArray (I# n#) e  = ST $ \s1# ->
 591   case newArray# n# e s1# of { (# s2#, marr# #) ->
 592   (# s2#, MPArr n# marr# #)}
 593
 594 -- convert a mutable array into the external parallel array representation
 595 --
 596 mkPArr                           :: Int -> MPArr s e -> ST s [:e:]
 597 {-# INLINE mkPArr #-}
 598 mkPArr (I# n#) (MPArr _ marr#)  = ST $ \s1# ->
 599   case unsafeFreezeArray# marr# s1#   of { (# s2#, arr# #) ->
 600   (# s2#, PArr n# arr# #) }
 601
 602 -- general array iterator
 603 --
 604 -- * corresponds to `loopA' from ``Functional Array Fusion'', Chakravarty &
 605 --   Keller, ICFP 2001
 606 --
 607 loop :: (e -> acc -> (Maybe e', acc))    -- mapping & folding, once per element
 608      -> acc                              -- initial acc value
 609      -> [:e:]                            -- input array
 610      -> ([:e':], acc)
 611 {-# INLINE loop #-}
 612 loop mf acc arr = loopFromTo 0 (lengthP arr - 1) mf acc arr
 613
 614 -- general array iterator with bounds
 615 --
 616 loopFromTo :: Int                        -- from index
 617            -> Int                        -- to index
 618            -> (e -> acc -> (Maybe e', acc))
 619            -> acc
 620            -> [:e:]
 621            -> ([:e':], acc)
 622 {-# INLINE loopFromTo #-}
 623 loopFromTo from to mf start arr = runST (do
 624   marr      <- newArray (to - from + 1) noElem
 625   (n', acc) <- trans from to marr arr mf start
 626   arr       <- mkPArr n' marr
 627   return (arr, acc))
 628   where
 629     noElem = error "GHC.PArr.loopFromTo: I do not exist!"
 630              -- unlike standard Haskell arrays, this value represents an
 631              -- internal error
 632
 633 -- actual loop body of `loop'
 634 --
 635 -- * for this to be really efficient, it has to be translated with the
 636 --   constructor specialisation phase "SpecConstr" switched on; as of GHC 5.03
 637 --   this requires an optimisation level of at least -O2
 638 --
 639 trans :: Int                            -- index of first elem to process
 640       -> Int                            -- index of last elem to process
 641       -> MPArr s e'                     -- destination array
 642       -> [:e:]                          -- source array
 643       -> (e -> acc -> (Maybe e', acc))  -- mutator
 644       -> acc                            -- initial accumulator
 645       -> ST s (Int, acc)                -- final destination length/final acc
 646 {-# INLINE trans #-}
 647 trans from to marr arr mf start = trans' from 0 start
 648   where
 649     trans' arrOff marrOff acc
 650       | arrOff > to = return (marrOff, acc)
 651       | otherwise   = do
 652                         let (oe', acc') = mf (arr `indexPArr` arrOff) acc
 653                         marrOff' <- case oe' of
 654                                       Nothing -> return marrOff
 655                                       Just e' -> do
 656                                         writeMPArr marr marrOff e'
 657                                         return $ marrOff + 1
 658                         trans' (arrOff + 1) marrOff' acc'
 659
 660 -- Permute the given elements into the mutable array.
 661 --
 662 permute :: MPArr s e -> [:Int:] -> [:e:] -> ST s ()
 663 permute marr is es = perm 0
 664   where
 665     perm i
 666       | i == n = return ()
 667       | otherwise  = writeMPArr marr (is!:i) (es!:i) >> perm (i + 1)
 668       where
 669         n = lengthP is
 670
 671
 672 -- common patterns for using `loop'
 673 --
 674
 675 -- initial value for the accumulator when the accumulator is not needed
 676 --
 677 noAL :: ()
 678 noAL  = ()
 679
 680 -- `loop' mutator maps a function over array elements
 681 --
 682 mapEFL   :: (e -> e') -> (e -> () -> (Maybe e', ()))
 683 {-# INLINE mapEFL #-}
 684 mapEFL f  = \e a -> (Just $ f e, ())
 685
 686 -- `loop' mutator that filter elements according to a predicate
 687 --
 688 filterEFL   :: (e -> Bool) -> (e -> () -> (Maybe e, ()))
 689 {-# INLINE filterEFL #-}
 690 filterEFL p  = \e a -> if p e then (Just e, ()) else (Nothing, ())
 691
 692 -- `loop' mutator for array folding
 693 --
 694 foldEFL   :: (e -> acc -> acc) -> (e -> acc -> (Maybe (), acc))
 695 {-# INLINE foldEFL #-}
 696 foldEFL f  = \e a -> (Nothing, f e a)
 697
 698 -- `loop' mutator for array scanning
 699 --
 700 scanEFL   :: (e -> acc -> acc) -> (e -> acc -> (Maybe acc, acc))
 701 {-# INLINE scanEFL #-}
 702 scanEFL f  = \e a -> (Just a, f e a)
 703
 704 -- elementary array operations
 705 --
 706
 707 -- unlifted array indexing
 708 --
 709 indexPArr                       :: [:e:] -> Int -> e
 710 {-# INLINE indexPArr #-}
 711 indexPArr (PArr n# arr#) (I# i#)
 712   | i# >=# 0# && i# <# n# =
 713     case indexArray# arr# i# of (# e #) -> e
 714   | otherwise = error $ "indexPArr: out of bounds parallel array index; " ++
 715                         "idx = " ++ show (I# i#) ++ ", arr len = "
 716                         ++ show (I# n#)
 717
 718 -- encapsulate writing into a mutable array into the `ST' monad
 719 --
 720 writeMPArr                           :: MPArr s e -> Int -> e -> ST s ()
 721 {-# INLINE writeMPArr #-}
 722 writeMPArr (MPArr n# marr#) (I# i#) e
 723   | i# >=# 0# && i# <# n# =
 724     ST $ \s# ->
 725     case writeArray# marr# i# e s# of s'# -> (# s'#, () #)
 726   | otherwise = error $ "writeMPArr: out of bounds parallel array index; " ++
 727                         "idx = " ++ show (I# i#) ++ ", arr len = "
 728                         ++ show (I# n#)
 729
 730 #endif /* __HADDOCK__ */
 731