GHC/PArr.hs

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