accelerate 0.15.1.0 → 1.0.0.0

raw patch · 73 files changed

+21557/−8841 lines, 73 filesdep +Win32dep +asyncdep +base-orphansdep −arraydep −blaze-htmldep −blaze-markupdep ~basedep ~containersdep ~fclabelsPVP ok

version bump matches the API change (PVP)

Dependencies added: Win32, async, base-orphans, deepseq, ekg, ekg-core, exceptions, time, transformers, unique

Dependencies removed: array, blaze-html, blaze-markup, bytestring

Dependency ranges changed: base, containers, fclabels, hashable, hashtables, pretty, text, unix, unordered-containers

API changes (from Hackage documentation)

Files

• Data/Array/Accelerate.hs +401/−181
• Data/Array/Accelerate/AST.hs +616/−78
• Data/Array/Accelerate/Analysis/Match.hs +1213/−1034
• Data/Array/Accelerate/Analysis/Shape.hs +28/−9
• Data/Array/Accelerate/Analysis/Stencil.hs +3/−3
• Data/Array/Accelerate/Analysis/Type.hs +29/−9
• Data/Array/Accelerate/Array/Data.hs +462/−248
• Data/Array/Accelerate/Array/Lifted.hs +283/−0
• Data/Array/Accelerate/Array/Remote.hs +26/−0
• Data/Array/Accelerate/Array/Remote/Class.hs +81/−0
• Data/Array/Accelerate/Array/Remote/LRU.hs +399/−0
• Data/Array/Accelerate/Array/Remote/Nursery.hs +122/−0
• Data/Array/Accelerate/Array/Remote/Table.hs +466/−0
• Data/Array/Accelerate/Array/Representation.hs +65/−21
• Data/Array/Accelerate/Array/Sugar.hs +1291/−1147
• Data/Array/Accelerate/Array/Unique.hs +94/−0
• Data/Array/Accelerate/Async.hs +103/−0
• Data/Array/Accelerate/Classes.hs +52/−0
• Data/Array/Accelerate/Classes/Bounded.hs +214/−0
• Data/Array/Accelerate/Classes/Enum.hs +70/−0
• Data/Array/Accelerate/Classes/Eq.hs +304/−0
• Data/Array/Accelerate/Classes/Floating.hs +123/−0
• Data/Array/Accelerate/Classes/Fractional.hs +55/−0
• Data/Array/Accelerate/Classes/FromIntegral.hs +85/−0
• Data/Array/Accelerate/Classes/Integral.hs +203/−0
• Data/Array/Accelerate/Classes/Num.hs +245/−0
• Data/Array/Accelerate/Classes/Ord.hs +493/−0
• Data/Array/Accelerate/Classes/Real.hs +40/−0
• Data/Array/Accelerate/Classes/RealFloat.hs +142/−0
• Data/Array/Accelerate/Classes/RealFrac.hs +165/−0
• Data/Array/Accelerate/Classes/ToFloating.hs +82/−0
• Data/Array/Accelerate/Data/Bits.hs +806/−0
• Data/Array/Accelerate/Data/Complex.hs +73/−42
• Data/Array/Accelerate/Data/Fold.hs +155/−0
• Data/Array/Accelerate/Data/Monoid.hs +172/−0
• Data/Array/Accelerate/Debug.hs +74/−307
• Data/Array/Accelerate/Debug/Flags.hs +305/−0
• Data/Array/Accelerate/Debug/Monitoring.hs +327/−0
• Data/Array/Accelerate/Debug/Stats.hs +210/−0
• Data/Array/Accelerate/Debug/Timed.hs +109/−0
• Data/Array/Accelerate/Debug/Trace.hs +137/−0
• Data/Array/Accelerate/Error.hs +17/−17
• Data/Array/Accelerate/FullList.hs +119/−0
• Data/Array/Accelerate/Interpreter.hs +790/−184
• Data/Array/Accelerate/Language.hs +1236/−930
• Data/Array/Accelerate/Lifetime.hs +156/−0
• Data/Array/Accelerate/Lift.hs +747/−0
• Data/Array/Accelerate/Prelude.hs +2009/−1678
• Data/Array/Accelerate/Pretty.hs +23/−16
• Data/Array/Accelerate/Pretty/Graphviz.hs +521/−118
• Data/Array/Accelerate/Pretty/Graphviz/Monad.hs +74/−0
• Data/Array/Accelerate/Pretty/Graphviz/Type.hs +142/−0
• Data/Array/Accelerate/Pretty/HTML.hs +0/−199
• Data/Array/Accelerate/Pretty/Print.hs +323/−159
• Data/Array/Accelerate/Pretty/Traverse.hs +0/−257
• Data/Array/Accelerate/Product.hs +177/−0
• Data/Array/Accelerate/Smart.hs +1795/−1105
• Data/Array/Accelerate/Trafo.hs +69/−21
• Data/Array/Accelerate/Trafo/Algebra.hs +174/−43
• Data/Array/Accelerate/Trafo/Base.hs +230/−45
• Data/Array/Accelerate/Trafo/Fusion.hs +586/−308
• Data/Array/Accelerate/Trafo/Rewrite.hs +55/−11
• Data/Array/Accelerate/Trafo/Sharing.hs +684/−52
• Data/Array/Accelerate/Trafo/Shrink.hs +101/−25
• Data/Array/Accelerate/Trafo/Simplify.hs +364/−78
• Data/Array/Accelerate/Trafo/Substitution.hs +386/−244
• Data/Array/Accelerate/Tuple.hs +0/−112
• Data/Array/Accelerate/Type.hs +123/−39
• Data/Atomic.hs +60/−0
• LICENSE +1/−1
• accelerate.cabal +257/−117
• cbits/atomic.c +12/−0
• changelog.md +3/−3

@@ -1,314 +1,534 @@ -- | -- Module      : Data.Array.Accelerate--- Copyright   : [2008..2014] Manuel M T Chakravarty, Gabriele Keller---               [2008..2009] Sean Lee---               [2009..2014] Trevor L. McDonell---               [2013..2014] Robert Clifton-Everest+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+--               [2013..2017] Robert Clifton-Everest+--               [2014..2014] Frederik M. Madsen -- License     : BSD3 ----- Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability   : experimental -- Portability : non-portable (GHC extensions) ----- This module defines an embedded language of array computations for--- high-performance computing. Computations on multi-dimensional, regular--- arrays are expressed in the form of parameterised collective operations--- (such as maps, reductions, and permutations). These computations are online--- compiled and executed on a range of architectures.+-- @Data.Array.Accelerate@ defines an embedded language of array computations+-- for high-performance computing in Haskell. Computations on multi-dimensional,+-- regular arrays are expressed in the form of parameterised collective+-- operations such as maps, reductions, and permutations. These computations are+-- online compiled and can be executed on a range of architectures. -- -- [/Abstract interface:/] ----- The types representing array computations are only exported abstractly —--- i.e., client code can generate array computations and submit them for--- execution, but it cannot inspect these computations. This is to allow for--- more flexibility for future extensions of this library.+-- The types representing array computations are only exported abstractly;+-- client code can generate array computations and submit them for execution,+-- but it cannot inspect these computations. This is to allow for more+-- flexibility for future extensions of this library. --+-- [/Stratified language:/]+--+-- Accelerate distinguishes the types of collective operations 'Acc' from the+-- type of scalar operations 'Exp' to achieve a stratified language. Collective+-- operations comprise many scalar computations that are executed in parallel,+-- but scalar computations /can not/ contain collective operations. This+-- separation excludes /nested, irregular/ data-parallelism statically; instead,+-- Accelerate is limited to /flat data-parallelism/ involving only regular,+-- multi-dimensional arrays.+--+-- [/Optimisations:/]+--+-- Accelerate uses a number of scalar and array optimisations, including+-- /array fusion/, in order to improve the performance of programs. Fusing+-- a program entails combining successive traversals (loops) over an array into+-- a single traversal, which reduces memory traffic and eliminates intermediate+-- arrays.+-- -- [/Code execution:/] ----- Access to the various backends is via a 'run' function in backend-specific--- top level modules. Currently, we have the following:+-- Several backends are available which can be used to evaluate accelerate+-- programs: -- -- * "Data.Array.Accelerate.Interpreter": simple interpreter in Haskell as a --   reference implementation defining the semantics of the Accelerate language ----- * "Data.Array.Accelerate.CUDA": an implementation supporting parallel---   execution on CUDA-capable NVIDIA GPUs+-- * <http://hackage.haskell.org/package/accelerate-llvm-native accelerate-llvm-native>:+--   implementation supporting parallel execution on multicore CPUs (e.g. x86). ----- [/Examples and documentation:/]+-- * <http://hackage.haskell.org/package/accelerate-llvm-ptx accelerate-llvm-ptx>:+--   implementation supporting parallel execution on CUDA-capable NVIDIA GPUs. ----- * A (draft) tutorial is available on the GitHub wiki:---   <https://github.com/AccelerateHS/accelerate/wiki>+-- * <http://hackage.haskell.org/package/accelerate-cuda accelerate-cuda>:+--   an older implementation supporting parallel execution on CUDA-capable+--   NVIDIA GPUs. /__NOTE:__ This backend is being deprecated in favour of @accelerate-llvm-ptx@./ ----- * The @accelerate-examples@ package demonstrates a range of computational---   kernels and several complete applications:---   <http://hackage.haskell.org/package/accelerate-examples>+-- [/Examples:/] --+-- * The <http://hackage.haskell.org/package/accelerate-examples accelerate-examples>+--   package demonstrates a range of computational kernels and several complete+--   applications:+--+--      - Implementation of the <https://en.wikipedia.org/wiki/Canny_edge_detector canny edge detector>+--      - Interactive <https://en.wikipedia.org/wiki/Mandelbrot_set Mandelbrot set> generator+--      - <https://en.wikipedia.org/wiki/N-body N-body simulation> of gravitational attraction between large bodies+--      - Implementation of the <https://en.wikipedia.org/wiki/Pagerank PageRank> algorithm+--      - A simple, real-time, interactive <https://en.wikipedia.org/wiki/Ray_tracing ray tracer>.+--      - A particle based simulation of stable fluid flows+--      - A cellular automaton simulation+--      - A "password recovery" tool, for dictionary attacks on MD5 hashes.+--+--      <<http://i.imgur.com/5Tbsp1j.jpg accelerate-mandelbrot>>+--      <<http://i.imgur.com/7ohhKm9.jpg accelerate-ray>>+--+-- * <http://hackage.haskell.org/package/lulesh-accelerate lulesh-accelerate>+--   is an implementation of the Livermore Unstructured Lagrangian Explicit+--   Shock Hydrodynamics (LULESH) application. LULESH is representative of+--   typical hydrodynamics codes, although simplified and hard-coded to solve+--   the Sedov blast problem on an unstructured hexahedron mesh.+--+--      - For more information on LULESH: <https://codesign.llnl.gov/lulesh.php>.+--+--      <<https://codesign.llnl.gov/images/sedov-3d-LLNL.png>>+--+-- [/Additional components:/]+--+-- * <https://hackage.haskell.org/package/accelerate-io accelerate-io>: Fast+-- conversion between Accelerate arrays and other formats (e.g. Repa, Vector).+--+-- * <https://hackage.haskell.org/package/accelerate-fft accelerate-fft>: Fast+-- Fourier transform, with FFI bindings to optimised implementations.+--+-- * <https://hackage.haskell.org/package/accelerate-bignum accelerate-bignum>:+-- Fixed-width large integer arithmetic.+--+-- * <https://hackage.haskell.org/package/colour-accelerate colour-accelerate>:+-- Colour representations in Accelerate (RGB, sRGB, HSV, and HSL).+--+-- * <https://hackage.haskell.org/package/gloss-accelerate gloss-accelerate>:+-- Generate <https://hackage.haskell.org/package/gloss gloss> pictures from+-- Accelerate.+--+-- * <https://hackage.haskell.org/package/gloss-raster-accelerate gloss-raster-accelerate>:+-- Parallel rendering of raster images and animations.+--+-- * <https://hackage.haskell.org/package/lens-accelerate lens-accelerate>:+-- <https://hackage.haskell.org/package/lens Lens> operators for Accelerate+-- types.+--+-- * <https://hackage.haskell.org/package/linear-accelerate linear-accelerate>:+-- <https://hackage.haskell.org/package/linear Linear> vector space types for+-- Accelerate.+--+-- * <https://hackage.haskell.org/package/mwc-random-accelerate mwc-random-accelerate>:+-- Generate Accelerate arrays filled with high-quality pseudorandom numbers.+--+-- [/Contact:/]+--+-- * Mailing list for both use and development discussion:+--+--     * <mailto:accelerate-haskell@googlegroups.com>+--     * http://groups.google.com/group/accelerate-haskell+--+-- * Bug reports: https://github.com/AccelerateHS/accelerate/issues+--+-- * Maintainers:+--+--     * Trevor L. McDonell: <mailto:tmcdonell@cse.unsw.edu.au>+--     * Manuel M T Chakravarty: <mailto:chak@cse.unsw.edu.au>+--+-- [/Tip:/]+--+-- Accelerate tends to stress GHC's garbage collector, so it helps to increase+-- the default GC allocation sizes. This can be done when running an executable+-- by specifying RTS options on the command line, for example:+--+-- > ./foo +RTS -A64M -n2M -RTS+--+-- You can make these settings the default by adding the following @ghc-options@+-- to your @.cabal@ file or similar:+--+-- > ghc-options: -with-rtsopts=-n2M -with-rtsopts=-A64M+--+-- To specify RTS options you will also need to compile your program with @-rtsopts@.+--  module Data.Array.Accelerate (    -- * The /Accelerate/ Array Language-  -- ** Array data types-  L.Acc, S.Arrays, S.Array, S.Scalar, S.Vector, S.Segments,+  -- ** Embedded array computations+  Acc, -  -- ** Array element types-  S.Elt,+  -- *** Arrays+  Array, Arrays, Scalar, Vector, Segments, -  -- ** Shapes & Indices-  ---  -- | Array indices are snoc type lists; that is, they are backwards and the-  -- end-of-list token, `Z`, occurs on the left. For example, the type of a-  -- rank-2 array index is @Z :. Int :. Int@.+  -- *** Array elements+  Elt,++  -- *** Array shapes & indices+  -- $shapes_and_indices   ---  S.Z(..), (S.:.)(..), S.Shape, S.All(..), S.Any(..), S.Slice(..),-  S.DIM0, S.DIM1, S.DIM2, S.DIM3, S.DIM4, S.DIM5, S.DIM6, S.DIM7, S.DIM8, S.DIM9,+  Z(..), (:.)(..),+  DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9,+  Shape, Slice(..), All(..), Any(..),+  -- Split(..), Divide(..), Division(..), -  -- ** Accessors-  -- *** Indexing-  (L.!), (L.!!), P.the,+  -- ** Array access+  -- *** Element indexing+  (!), (!!), the,    -- *** Shape information-  P.null, P.length, L.shape, L.size, L.shapeSize,--  -- *** Extracting sub-arrays-  L.slice,-  P.init, P.tail, P.take, P.drop, P.slit,+  null, length, shape, size, shapeSize,    -- ** Construction   -- *** Introduction-  L.use, L.unit,+  use, unit,    -- *** Initialisation-  L.generate, L.replicate, P.fill,+  generate, fill,    -- *** Enumeration-  P.enumFromN, P.enumFromStepN,+  enumFromN, enumFromStepN,    -- *** Concatenation-  (P.++),+  (++),    -- ** Composition   -- *** Flow control-  (P.?|), L.acond, L.awhile,--  -- *** Pipelining-  (L.>->),--  -- ** Modifying Arrays-  -- *** Shape manipulation-  L.reshape, P.flatten,--  -- *** Permutations-  L.permute, L.backpermute, L.ignore,+  (?|), acond, awhile,+  IfThenElse(..), -  -- *** Specialised permutations-  P.reverse, P.transpose,+  -- *** Controlling execution+  (>->),+  compute,    -- ** Element-wise operations+  -- *** Indexing+  indexed,+   -- *** Mapping-  L.map,+  map, imap,    -- *** Zipping-  L.zipWith, P.zipWith3, P.zipWith4, P.zipWith5, P.zipWith6, P.zipWith7, P.zipWith8, P.zipWith9,-  P.zip, P.zip3, P.zip4, P.zip5, P.zip6, P.zip7, P.zip8, P.zip9,+  zipWith, zipWith3, zipWith4, zipWith5, zipWith6, zipWith7, zipWith8, zipWith9,+  izipWith, izipWith3, izipWith4, izipWith5, izipWith6, izipWith7, izipWith8, izipWith9,+  zip, zip3, zip4, zip5, zip6, zip7, zip8, zip9,    -- *** Unzipping-  P.unzip, P.unzip3, P.unzip4, P.unzip5, P.unzip6, P.unzip7, P.unzip8, P.unzip9,+  unzip, unzip3, unzip4, unzip5, unzip6, unzip7, unzip8, unzip9, -  -- ** Working with predicates-  -- *** Filtering-  P.filter,+  -- ** Modifying Arrays+  -- *** Shape manipulation+  reshape, flatten, -  -- *** Scatter-  P.scatter, P.scatterIf,+  -- *** Replication+  replicate, -  -- *** Gather-  P.gather,  P.gatherIf,+  -- *** Extracting sub-arrays+  slice,+  init, tail, take, drop, slit, +  -- *** Permutations+  -- **** Forward permutation (scatter)+  permute,+  ignore,+  scatter,++  -- **** Backward permutation (gather)+  backpermute,+  gather,++  -- **** Specialised permutations+  reverse, transpose,++  -- *** Filtering+  filter,+   -- ** Folding-  L.fold, L.fold1, P.foldAll, P.fold1All,+  fold, fold1, foldAll, fold1All,    -- *** Segmented reductions-  L.foldSeg, L.fold1Seg,+  foldSeg, fold1Seg, -  -- *** Specialised folds-  P.all, P.any, P.and, P.or, P.sum, P.product, P.minimum, P.maximum,+  -- *** Specialised reductions+  all, any, and, or, sum, product, minimum, maximum, -  -- ** Prefix sums (scans)-  L.scanl, L.scanl1, L.scanl', L.scanr, L.scanr1, L.scanr',-  P.prescanl, P.postscanl, P.prescanr, P.postscanr,+  -- ** Scans (prefix sums)+  scanl, scanl1, scanl', scanr, scanr1, scanr',+  prescanl, postscanl, prescanr, postscanr,    -- *** Segmented scans-  P.scanlSeg, P.scanl1Seg, P.scanl'Seg, P.prescanlSeg, P.postscanlSeg,-  P.scanrSeg, P.scanr1Seg, P.scanr'Seg, P.prescanrSeg, P.postscanrSeg,+  scanlSeg, scanl1Seg, scanl'Seg, prescanlSeg, postscanlSeg,+  scanrSeg, scanr1Seg, scanr'Seg, prescanrSeg, postscanrSeg, -  -- ** Stencil-  L.stencil, L.stencil2,+  -- ** Stencils+  stencil, stencil2, -  -- *** Specification-  L.Stencil, L.Boundary(..),+  -- *** Stencil specification+  Stencil, Boundary(..),    -- *** Common stencil patterns-  L.Stencil3, L.Stencil5, L.Stencil7, L.Stencil9,-  L.Stencil3x3, L.Stencil5x3, L.Stencil3x5, L.Stencil5x5,-  L.Stencil3x3x3, L.Stencil5x3x3, L.Stencil3x5x3, L.Stencil3x3x5, L.Stencil5x5x3, L.Stencil5x3x5,-  L.Stencil3x5x5, L.Stencil5x5x5,+  Stencil3, Stencil5, Stencil7, Stencil9,+  Stencil3x3, Stencil5x3, Stencil3x5, Stencil5x5,+  Stencil3x3x3, Stencil5x3x3, Stencil3x5x3, Stencil3x3x5, Stencil5x5x3, Stencil5x3x5,+  Stencil3x5x5, Stencil5x5x5, -  -- ** Foreign-  L.foreignAcc, L.foreignAcc2, L.foreignAcc3,-  L.foreignExp, L.foreignExp2, L.foreignExp3,+  -- -- ** Sequence operations+  -- collect, -  -- ---------------------------------------------------------------------------+  -- -- ** Sequence producers+  -- streamIn, toSeq, generateSeq, +  -- -- ** Sequence transducers+  -- mapSeq, zipWithSeq, scanSeq,++  -- -- ** Sequence consumers+  -- foldSeq, foldSeqFlatten, fromSeq, fromSeqElems, fromSeqShapes,+  -- toSeqInner, toSeqOuter2, toSeqOuter3,++  -- ---------------------------------------------------------------------------   -- * The /Accelerate/ Expression Language   -- ** Scalar data types-  L.Exp,+  Exp,    -- ** Type classes-  T.IsScalar, T.IsNum, T.IsBounded, T.IsIntegral, T.IsFloating, T.IsNonNum,--  -- ** Element types-  T.Int, T.Int8, T.Int16, T.Int32, T.Int64, T.Word, T.Word8, T.Word16, T.Word32, T.Word64,-  T.CShort, T.CUShort, T.CInt, T.CUInt, T.CLong, T.CULong, T.CLLong, T.CULLong,-  Float, Double, T.CFloat, T.CDouble,-  Bool, Char, T.CChar, T.CSChar, T.CUChar,+  -- *** Basic type classes+  Eq(..),+  Ord(..),+  -- Enum, -- vacuous+  Bounded, minBound, maxBound, -  -- ** Lifting and Unlifting+  -- *** Numeric type classes+  Num, (+), (-), (*), negate, abs, signum, fromInteger,+  -- Real, -- vacuous+  Integral, quot, rem, div, mod, quotRem, divMod,+  Fractional, (/), recip, fromRational,+  Floating, pi, sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh, exp, sqrt, log, (**), logBase,+  RealFrac(..), div', mod', divMod',+  RealFloat(..), -  -- | A value of type `Int` is a plain Haskell value (unlifted), whereas an-  -- @Exp Int@ is a /lifted/ value, that is, an integer lifted into the domain-  -- of expressions (an abstract syntax tree in disguise). Both `Acc` and `Exp`-  -- are /surface types/ into which values may be lifted. Lifting plain array-  -- and scalar surface types is equivalent to 'use' and 'constant'-  -- respectively.-  ---  -- In general an @Exp Int@ cannot be unlifted into an `Int`, because the-  -- actual number will not be available until a later stage of execution (e.g.-  -- during GPU execution, when `run` is called). Similarly an @Acc array@ can-  -- not be unlifted to a vanilla `array`; you should instead `run` the-  -- expression with a specific backend to evaluate it.-  ---  -- Lifting and unlifting are also used to pack and unpack an expression into-  -- and out of constructors such as tuples, respectively. Those expressions, at-  -- runtime, will become tuple dereferences. For example:-  ---  -- > Exp (Z :. Int :. Int)-  -- >     -> unlift    :: (Z :. Exp Int :. Exp Int)-  -- >     -> lift      :: Exp (Z :. Int :. Int)-  -- >     -> ...-  ---  -- > Acc (Scalar Int, Vector Float)-  -- >     -> unlift    :: (Acc (Scalar Int), Acc (Vector Float))-  -- >     -> lift      :: Acc (Scalar Int, Vector Float)-  -- >     -> ...-  ---  P.Lift(..), P.Unlift(..), P.lift1, P.lift2, P.ilift1, P.ilift2,+  -- *** Numeric conversion classes+  FromIntegral(..),+  ToFloating(..), -  -- ** Operations-  ---  -- | Some of the standard Haskell 98 typeclass functions need to be-  -- reimplemented because their types change. If so, function names kept the-  -- same and infix operations are suffixed by an asterisk. If not reimplemented-  -- here, the standard typeclass instances apply.+  -- ** Lifting and Unlifting+  -- $lifting_and_unlifting   --+  Lift(..), Unlift(..),+  lift1, lift2, lift3,+  ilift1, ilift2, ilift3, +  -- ** Scalar operations   -- *** Introduction-  L.constant,+  constant,    -- *** Tuples-  P.fst, P.afst, P.snd, P.asnd, P.curry, P.uncurry,+  fst, afst, snd, asnd, curry, uncurry,    -- *** Flow control-  (P.?), P.caseof, L.cond, L.while, P.iterate,+  (?), caseof, cond, while, iterate,    -- *** Scalar reduction-  P.sfoldl,--  -- *** Basic operations-  (L.&&*), (L.||*), L.not,-  (L.==*), (L./=*), (L.<*), (L.<=*), (L.>*), (L.>=*),+  sfoldl, -  -- *** Numeric functions-  L.truncate, L.round, L.floor, L.ceiling, L.even, L.odd,+  -- *** Logical operations+  (&&), (||), not, -  -- *** Bitwise functions-  L.bit, L.setBit, L.clearBit, L.complementBit, L.testBit,-  L.shift,  L.shiftL,  L.shiftR,-  L.rotate, L.rotateL, L.rotateR,+  -- *** Numeric operations+  subtract, even, odd, gcd, lcm, (^), (^^),    -- *** Shape manipulation-  P.index0, P.index1, P.unindex1, P.index2, P.unindex2,-  L.indexHead, L.indexTail,-  L.toIndex, L.fromIndex,-  L.intersect,+  index0, index1, unindex1, index2, unindex2, index3, unindex3,+  indexHead, indexTail,+  toIndex, fromIndex,+  intersect,    -- *** Conversions-  L.ord, L.chr, L.boolToInt, L.fromIntegral,+  ord, chr, boolToInt, bitcast,    -- ---------------------------------------------------------------------------+  -- * Foreign Function Interface (FFI)+  foreignAcc,+  foreignExp, +  -- ---------------------------------------------------------------------------   -- * Plain arrays   -- ** Operations-  arrayDim, arrayShape, arraySize, indexArray,+  arrayRank, arrayShape, arraySize, indexArray, -  -- ** Conversions-  ---  -- | For additional conversion routines, see the accelerate-io package:-  -- <http://hackage.haskell.org/package/accelerate-io>+  -- ** Getting data in+  -- $getting_data_in    -- *** Function   fromFunction,    -- *** Lists-  S.fromList, S.toList,+  fromList, toList, -  -- *** 'Data.Array.IArray.IArray'-  S.fromIArray, S.toIArray,+  -- ---------------------------------------------------------------------------+  -- * Prelude re-exports+  (.), ($), error, undefined, const, +  -- ---------------------------------------------------------------------------+  -- Types+  Int, Int8, Int16, Int32, Int64,+  Word, Word8, Word16, Word32, Word64,+  Float, Double,+  Bool(..), Char,++  CFloat, CDouble,+  CShort, CUShort, CInt, CUInt, CLong, CULong, CLLong, CULLong,+  CChar, CSChar, CUChar,++  -- | Avoid using these in your own functions wherever possible.+  IsScalar, IsNum, IsBounded, IsIntegral, IsFloating, IsNonNum,+ ) where  -- friends-import Data.Array.Accelerate.Trafo                  () -- show instances-import qualified Data.Array.Accelerate.Array.Sugar  as S-import qualified Data.Array.Accelerate.Language     as L-import qualified Data.Array.Accelerate.Prelude      as P-import qualified Data.Array.Accelerate.Type         as T+import Data.Array.Accelerate.Array.Sugar                            hiding ( (!), rank, shape, size, toIndex, fromIndex, intersect, ignore )+import Data.Array.Accelerate.Classes+import Data.Array.Accelerate.Language+import Data.Array.Accelerate.Prelude+import Data.Array.Accelerate.Trafo                                  () -- show instances+import Data.Array.Accelerate.Type+import qualified Data.Array.Accelerate.Array.Sugar                  as S --- system-import Prelude (Float, Double, Bool, Char)+-- re-exported from D.A.A.Classes.Num but not found (GHC<8 bug)+import Prelude                                                      ( (.), ($), undefined, error, const, fromInteger )   -- Renamings+-- --------- --- -- FIXME: these all need to go into a separate module for separate importing!  -- rename as '(!)' is already used by the EDSL for indexing --- |Array indexing in plain Haskell code.+-- | Array indexing in plain Haskell code. ---indexArray :: S.Array sh e -> sh -> e+indexArray :: Array sh e -> sh -> e indexArray = (S.!)  -- | Rank of an array. ---arrayDim :: S.Shape sh => sh -> T.Int-arrayDim = S.dim--- FIXME: Rename to rank+arrayRank :: Shape sh => sh -> Int+arrayRank = S.rank  -- |Array shape in plain Haskell code. ---arrayShape :: S.Shape sh => S.Array sh e -> sh+arrayShape :: Shape sh => Array sh e -> sh arrayShape = S.shape -- rename as 'shape' is already used by the EDSL to query an array's shape  -- | Total number of elements in an array of the given 'Shape'. ---arraySize :: S.Shape sh => sh -> T.Int+arraySize :: Shape sh => sh -> Int arraySize = S.size --- | Create an array from its representation function.+-- Named documentation chunks+-- --------------------------++-- $shapes_and_indices ---{-# INLINE fromFunction #-}-fromFunction :: (S.Shape sh, S.Elt e) => sh -> (sh -> e) -> S.Array sh e-fromFunction = S.newArray+-- Operations in Accelerate take the form of collective operations over arrays+-- of the type @'Array' sh e@. Much like the+-- <https://hackage.haskell.org/package/repa repa> library, arrays in Accelerate+-- are parameterised by a type /sh/ which determines the dimensionality of the+-- array and the type of each index, as well as the type of each element of the+-- array /e/.+--+-- Shape types, and multidimensional array indices, are built like lists+-- (technically; a heterogeneous snoc-list) using 'Z' and (':.'):+--+-- > data Z = Z+-- > data tail :. head = tail :. head+--+-- Here, the constructor 'Z' corresponds to a shape with zero dimension (or+-- a 'Scalar' array, with one element) and is used to mark the end of the list.+-- The constructor (':.') adds additional dimensions to the shape on the+-- /right/. For example:+--+-- > Z :. Int+--+-- is the type of the shape of a one-dimensional array ('Vector') indexed by an+-- 'Int', while:+--+-- > Z :. Int :. Int+--+-- is the type of the shape of a two-dimensional array (a matrix) indexed by an+-- 'Int' in each dimension.+--+-- This style is used to construct both the /type/ and /value/ of the shape. For+-- example, to define the shape of a vector of ten elements:+--+-- > sh :: Z :. Int+-- > sh = Z :. 10+--+-- Note that the right-most index is the /innermost/ dimension. This is the+-- fastest-varying index, and corresponds to the elements of the array which are+-- adjacent in memory.+--++-- $lifting_and_unlifting+--+-- A value of type 'Int' is a plain Haskell value (unlifted), whereas an @Exp+-- Int@ is a /lifted/ value, that is, an integer lifted into the domain of+-- embedded expressions (an abstract syntax tree in disguise). Both 'Acc' and+-- 'Exp' are /surface types/ into which values may be lifted. Lifting plain+-- array and scalar surface types is equivalent to 'use' and 'constant'+-- respectively.+--+-- In general an @Exp Int@ cannot be unlifted into an 'Int', because the actual+-- number will not be available until a later stage of execution (e.g. during+-- GPU execution, when 'run' is called). Similarly an @Acc array@ can not be+-- unlifted to a vanilla 'array'; you should instead 'run' the expression with+-- a specific backend to evaluate it.+--+-- Lifting and unlifting are also used to pack and unpack an expression into and+-- out of constructors such as tuples, respectively. Those expressions, at+-- runtime, will become tuple dereferences. For example:+--+-- >>> let sh = constant (Z :. 4 :. 10)   :: Exp DIM2+-- >>> let Z :. x :. y = unlift sh        :: Z :. Exp Int :. Exp Int+-- >>> let t = lift (x,y)                 :: Exp (Int, Int)+--+-- >>> let r  = scanl' f z xs             :: (Acc (Vector Int), Acc (Scalar Int))+-- >>> let r' = lift r                    :: Acc (Vector Int, Scalar Int)+--+-- [/Note:/]+--+-- Use of 'lift' and 'unlift' is probably the most common source of type errors+-- when using Accelerate. GHC is not very good at determining the type the+-- [un]lifted expression should have, so it is often necessary to add an+-- explicit type signature.+--+-- For example, in the following GHC will complain that it can not determine the+-- type of 'y', even though we might expect that to be obvious (or for it to not+-- care):+--+-- > fst :: (Elt a, Elt b) => Exp (a,b) -> Exp a+-- > fst t = let (x,y) = unlift t in x+--+-- The fix is to instead add an explicit type signature. Note that this requires+-- the @ScopedTypeVariables@ extension and to bring the type variables @a@ and+-- @b@ into scope with @forall@:+--+-- > fst :: forall a b. (Elt a, Elt b) => Exp (a,b) -> Exp a+-- > fst t = let (x,y) = unlift t  :: (Exp a, Exp b)+-- >         in x+--++-- $getting_data_in+-- #getting_data_in#+--+-- We often need to generate or read data into an 'Array' so that it can be used+-- in Accelerate. The base @accelerate@ library includes basic conversions+-- routines, but for additional functionality see the+-- <http://hackage.haskell.org/package/accelerate-io accelerate-io> package,+-- which includes conversions between:+--+--  * <https://hackage.haskell.org/package/repa repa>: another Haskell library for high-performance parallel arrays+--  * <https://hackage.haskell.org/package/vector vector>: efficient boxed and unboxed one-dimensional arrays+--  * <https://hackage.haskell.org/package/array array>: immutable arrays+--  * <https://hackage.haskell.org/package/bmp BMP>: uncompressed BMP image files+--  * <https://hackage.haskell.org/package/bytestring bytestring> compact, immutable binary data+--  * As well as copying data directly from raw 'Foreign.Ptr.Ptr's+-- 

@@ -1,8 +1,11 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-} {-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TemplateHaskell       #-}@@ -12,13 +15,14 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.AST--- Copyright   : [2008..2014] Manuel M T Chakravarty, Gabriele Keller---               [2008..2009] Sean Lee---               [2009..2014] Trevor L. McDonell+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell --               [2010..2011] Ben Lever+--               [2013..2017] Robert Clifton-Everest+--               [2014..2014] Frederik M. Madsen -- License     : BSD3 ----- Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -88,10 +92,18 @@   PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc,   Stencil(..), StencilR(..), +  -- * Accelerated sequences+  -- PreOpenSeq(..), Seq,+  -- Producer(..), Consumer(..),+   -- * Scalar expressions   PreOpenFun(..), OpenFun, PreFun, Fun, PreOpenExp(..), OpenExp, PreExp, Exp, PrimConst(..),   PrimFun(..), +  -- NFData+  NFDataAcc,+  rnfPreOpenAfun, rnfPreOpenAcc, rnfPreOpenFun, rnfPreOpenExp,+   -- debugging   showPreAccOp, showPreExpOp, @@ -100,13 +112,16 @@ --standard library import Data.List import Data.Typeable+import Control.DeepSeq  -- friends-import Data.Array.Accelerate.Error import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Tuple-import Data.Array.Accelerate.Array.Representation       ( SliceIndex )+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Array.Representation       ( SliceIndex(..) ) import Data.Array.Accelerate.Array.Sugar                as Sugar+#if __GLASGOW_HASKELL__ < 800+import Data.Array.Accelerate.Error+#endif   -- Typed de Bruijn indices@@ -153,15 +168,18 @@ prj :: Idx env t -> Val env -> t prj ZeroIdx       (Push _   v) = v prj (SuccIdx idx) (Push val _) = prj idx val+#if __GLASGOW_HASKELL__ < 800 prj _             _            = $internalError "prj" "inconsistent valuation"+#endif  -- Projection of a value from a valuation of array elements using a de Bruijn index -- prjElt :: Idx env t -> ValElt env -> t prjElt ZeroIdx       (PushElt _   v) = Sugar.toElt v prjElt (SuccIdx idx) (PushElt val _) = prjElt idx val+#if __GLASGOW_HASKELL__ < 800 prjElt _             _               = $internalError "prjElt" "inconsistent valuation"-+#endif  -- Array expressions -- -----------------@@ -184,6 +202,18 @@ -- type Afun = OpenAfun () +-- Vanilla open array computations+--+newtype OpenAcc aenv t = OpenAcc (PreOpenAcc OpenAcc aenv t)++-- |Closed array expression aka an array program+--+type Acc = OpenAcc ()++deriving instance Typeable PreOpenAcc+deriving instance Typeable OpenAcc++ -- |Collective array computations parametrised over array variables -- represented with de Bruijn indices. --@@ -218,11 +248,11 @@               -> PreOpenAcc acc aenv arrs    -- Tuples of arrays-  Atuple      :: (Arrays arrs, IsTuple arrs)+  Atuple      :: (Arrays arrs, IsAtuple arrs)               => Atuple    (acc aenv) (TupleRepr arrs)               -> PreOpenAcc acc aenv  arrs -  Aprj        :: (Arrays arrs, IsTuple arrs, Arrays a)+  Aprj        :: (Arrays arrs, IsAtuple arrs, Arrays a)               => TupleIdx (TupleRepr arrs) a               ->            acc aenv arrs               -> PreOpenAcc acc aenv a@@ -240,11 +270,11 @@   -- Apply a backend-specific foreign function to an array, with a pure   -- Accelerate version for use with other backends. The functions must be   -- closed.-  Aforeign    :: (Arrays arrs, Arrays a, Foreign f)-              => f arrs a                                       -- The foreign function for a given backend-              -> PreAfun      acc      (arrs -> a)              -- A pure accelerate version-              -> acc              aenv arrs                     -- Arguments to the function-              -> PreOpenAcc   acc aenv a+  Aforeign    :: (Arrays as, Arrays bs, Foreign asm)+              => asm                   (as -> bs)               -- The foreign function for a given backend+              -> PreAfun      acc      (as -> bs)               -- Fallback implementation(s)+              -> acc              aenv as                       -- Arguments to the function+              -> PreOpenAcc   acc aenv bs    -- If-then-else for array-level computations   Acond       :: Arrays arrs@@ -361,46 +391,46 @@   -- Left-to-right Haskell-style scan of a linear array with a given *associative*   -- function and an initial element (which does not need to be the neutral of the   -- associative operations)-  Scanl       :: Elt e+  Scanl       :: (Shape sh, Elt e)               => PreFun     acc aenv (e -> e -> e)              -- combination function               -> PreExp     acc aenv e                          -- initial value-              -> acc            aenv (Vector e)                 -- linear array-              -> PreOpenAcc acc aenv (Vector e)+              -> acc            aenv (Array (sh:.Int) e)+              -> PreOpenAcc acc aenv (Array (sh:.Int) e)     -- FIXME: Make the scans rank-polymorphic?    -- Like 'Scan', but produces a rightmost fold value and an array with the same length as the input   -- array (the fold value would be the rightmost element in a Haskell-style scan)-  Scanl'      :: Elt e+  Scanl'      :: (Shape sh, Elt e)               => PreFun     acc aenv (e -> e -> e)              -- combination function               -> PreExp     acc aenv e                          -- initial value-              -> acc            aenv (Vector e)                 -- linear array-              -> PreOpenAcc acc aenv (Vector e, Scalar e)+              -> acc            aenv (Array (sh:.Int) e)+              -> PreOpenAcc acc aenv (Array (sh:.Int) e, Array sh e)    -- Haskell-style scan without an initial value-  Scanl1      :: Elt e+  Scanl1      :: (Shape sh, Elt e)               => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> acc            aenv (Vector e)                 -- linear array-              -> PreOpenAcc acc aenv (Vector e)+              -> acc            aenv (Array (sh:.Int) e)+              -> PreOpenAcc acc aenv (Array (sh:.Int) e)    -- Right-to-left version of 'Scanl'-  Scanr       :: Elt e+  Scanr       :: (Shape sh, Elt e)               => PreFun     acc aenv (e -> e -> e)              -- combination function               -> PreExp     acc aenv e                          -- initial value-              -> acc            aenv (Vector e)                 -- linear array-              -> PreOpenAcc acc aenv (Vector e)+              -> acc            aenv (Array (sh:.Int) e)+              -> PreOpenAcc acc aenv (Array (sh:.Int) e)    -- Right-to-left version of 'Scanl\''-  Scanr'      :: Elt e+  Scanr'      :: (Shape sh, Elt e)               => PreFun     acc aenv (e -> e -> e)              -- combination function               -> PreExp     acc aenv e                          -- initial value-              -> acc            aenv (Vector e)                 -- linear array-              -> PreOpenAcc acc aenv (Vector e, Scalar e)+              -> acc            aenv (Array (sh:.Int) e)+              -> PreOpenAcc acc aenv (Array (sh:.Int) e, Array sh e)    -- Right-to-left version of 'Scanl1'-  Scanr1      :: Elt e+  Scanr1      :: (Shape sh, Elt e)               => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> acc            aenv (Vector e)                 -- linear array-              -> PreOpenAcc acc aenv (Vector e)+              -> acc            aenv (Array (sh:.Int) e)+              -> PreOpenAcc acc aenv (Array (sh:.Int) e)    -- Generalised forward permutation is characterised by a permutation function   -- that determines for each element of the source array where it should go in@@ -457,21 +487,132 @@               -> acc            aenv (Array sh e2)              -- source array #2               -> PreOpenAcc acc aenv (Array sh e') +  -- A sequence of operations.+  -- Collect     :: Arrays arrs+  --             => PreOpenSeq acc aenv () arrs+  --             -> PreOpenAcc acc aenv arrs --- Vanilla open array computations----newtype OpenAcc aenv t = OpenAcc (PreOpenAcc OpenAcc aenv t)+{--+data PreOpenSeq acc aenv senv arrs where+  Producer :: Arrays a+           => Producer acc aenv senv a+           -> PreOpenSeq acc aenv (senv, a) arrs+           -> PreOpenSeq acc aenv senv arrs --- deriving instance Typeable PreOpenAcc-deriving instance Typeable OpenAcc+  Consumer :: Arrays arrs+           => Consumer acc aenv senv arrs+           -> PreOpenSeq acc aenv senv arrs --- |Closed array expression aka an array program+  Reify    :: Arrays arrs+           => Idx senv arrs+           -> PreOpenSeq acc aenv senv [arrs]++data Producer acc aenv senv a where+  -- Convert the given Haskell-list of arrays to a sequence.+  StreamIn :: Arrays a+           => [a]+           -> Producer acc aenv senv a++  -- Convert the given array to a sequence.+  ToSeq :: (Elt slix, Shape sl, Shape sh, Elt e)+           => SliceIndex  (EltRepr slix)+                          (EltRepr sl)+                          co+                          (EltRepr sh)+           -> proxy slix+           -> acc aenv (Array sh e)+           -> Producer acc aenv senv (Array sl e)++  -- Apply the given the given function to all elements of the given+  -- sequence.+  MapSeq :: (Arrays a, Arrays b)+         => PreOpenAfun acc aenv (a -> b)+         -> Idx senv a+         -> Producer acc aenv senv b++  -- Apply the given the given function to all elements of the given+  -- sequence.+  ChunkedMapSeq :: (Arrays a, Arrays b)+                => PreOpenAfun acc aenv (Vector' a -> Vector' b)+                -> Idx senv a+                -> Producer acc aenv senv b++  -- Apply a given binary function pairwise to all elements of the+  -- given sequences.+  ZipWithSeq :: (Arrays a, Arrays b, Arrays c)+             => PreOpenAfun acc aenv (a -> b -> c)+             -> Idx senv a+             -> Idx senv b+             -> Producer acc aenv senv c++  -- ScanSeq (+) a0 x. Scan a sequence x by combining each element+  -- using the given binary operation (+). (+) must be associative:+  --+  --   Forall a b c. (a + b) + c = a + (b + c),+  --+  -- and a0 must be the identity element for (+):+  --+  --   Forall a. a0 + a = a = a + a0.+  --+  ScanSeq :: Elt e+          => PreFun acc aenv (e -> e -> e)+          -> PreExp acc aenv e+          -> Idx senv (Scalar e)+          -> Producer acc aenv senv (Scalar e)++data Consumer acc aenv senv a where++  -- FoldSeq (+) a0 x. Fold a sequence x by combining each element+  -- using the given binary operation (+). (+) must be associative:+  --+  --   Forall a b c. (a + b) + c = a + (b + c),+  --+  -- and a0 must be the identity element for (+):+  --+  --   Forall a. a0 + a = a = a + a0.+  --+  FoldSeq :: Elt a+          => PreFun acc aenv (a -> a -> a)+          -> PreExp acc aenv a+          -> Idx senv (Scalar a)+          -> Consumer acc aenv senv (Scalar a)++  -- FoldSeqFlatten f a0 x. A specialized version of FoldSeqAct where+  -- reduction with the companion operator corresponds to+  -- flattening. f must be semi-associative, with vecotor append (++)+  -- as the companion operator:+  --+  --   Forall b sh1 a1 sh2 a2.+  --     f (f b sh1 a1) sh2 a2 = f b (sh1 ++ sh2) (a1 ++ a2).+  --+  -- It is common to ignore the shape vectors, yielding the usual+  -- semi-associativity law:+  --+  --   f b a _ = b + a,+  --+  -- for some (+) satisfying:+  --+  --   Forall b a1 a2. (b + a1) + a2 = b + (a1 ++ a2).+  --+  FoldSeqFlatten :: (Arrays a, Shape sh, Elt e)+                 => PreOpenAfun acc aenv (a -> Vector sh -> Vector e -> a)+                 -> acc aenv a+                 -> Idx senv (Array sh e)+                 -> Consumer acc aenv senv a++  Stuple :: (Arrays a, IsAtuple a)+         => Atuple (Consumer acc aenv senv) (TupleRepr a)+         -> Consumer acc aenv senv a++-- |Closed sequence computation ---type Acc = OpenAcc ()+type Seq = PreOpenSeq OpenAcc () ()+--} + -- |Operations on stencils. ---class (Shape sh, Elt e, IsTuple stencil) => Stencil sh e stencil where+class (Shape sh, Elt e, IsTuple stencil, Elt stencil) => Stencil sh e stencil where   stencil       :: StencilR sh e stencil   stencilAccess :: (sh -> e) -> sh -> stencil @@ -692,6 +833,18 @@ -- type Fun = OpenFun () +-- |Vanilla open expression+--+type OpenExp = PreOpenExp OpenAcc++-- |Parametrised expression without free scalar variables+--+type PreExp acc = PreOpenExp acc ()++-- |Vanilla expression without free scalar variables+--+type Exp = OpenExp ()+ -- |Parametrised open expressions using de Bruijn indices for variables ranging over tuples -- of scalars and arrays of tuples.  All code, except Cond, is evaluated eagerly.  N-tuples are -- represented as nested pairs.@@ -712,8 +865,8 @@                 -> PreOpenExp acc env aenv t    -- Apply a backend-specific foreign function-  Foreign       :: (Foreign f, Elt x, Elt y)-                => f x y+  Foreign       :: (Foreign asm, Elt x, Elt y)+                => asm           (x -> y)                 -> PreFun acc () (x -> y)                 -> PreOpenExp acc env aenv x                 -> PreOpenExp acc env aenv y@@ -829,20 +982,14 @@                 -> PreOpenExp acc env aenv dim                 -> PreOpenExp acc env aenv dim +  -- Union of two shapes+  Union         :: Shape dim+                => PreOpenExp acc env aenv dim+                -> PreOpenExp acc env aenv dim+                -> PreOpenExp acc env aenv dim --- |Vanilla open expression----type OpenExp = PreOpenExp OpenAcc --- |Parametrised expression without free scalar variables----type PreExp acc = PreOpenExp acc ()---- |Vanilla expression without free scalar variables----type Exp = OpenExp ()---- |Primitive GPU constants+-- |Primitive constant values -- data PrimConst ty where @@ -865,22 +1012,28 @@   PrimAbs  :: NumType a -> PrimFun (a      -> a)   PrimSig  :: NumType a -> PrimFun (a      -> a) -  -- operators from Integral & Bits+  -- operators from Integral   PrimQuot     :: IntegralType a -> PrimFun ((a, a)   -> a)   PrimRem      :: IntegralType a -> PrimFun ((a, a)   -> a)+  PrimQuotRem  :: IntegralType a -> PrimFun ((a, a)   -> (a, a))   PrimIDiv     :: IntegralType a -> PrimFun ((a, a)   -> a)   PrimMod      :: IntegralType a -> PrimFun ((a, a)   -> a)-  PrimBAnd     :: IntegralType a -> PrimFun ((a, a)   -> a)-  PrimBOr      :: IntegralType a -> PrimFun ((a, a)   -> a)-  PrimBXor     :: IntegralType a -> PrimFun ((a, a)   -> a)-  PrimBNot     :: IntegralType a -> PrimFun (a        -> a)-  PrimBShiftL  :: IntegralType a -> PrimFun ((a, Int) -> a)-  PrimBShiftR  :: IntegralType a -> PrimFun ((a, Int) -> a)-  PrimBRotateL :: IntegralType a -> PrimFun ((a, Int) -> a)-  PrimBRotateR :: IntegralType a -> PrimFun ((a, Int) -> a)+  PrimDivMod   :: IntegralType a -> PrimFun ((a, a)   -> (a, a)) -  -- operators from Fractional, Floating, RealFrac & RealFloat+  -- operators from Bits & FiniteBits+  PrimBAnd               :: IntegralType a -> PrimFun ((a, a)   -> a)+  PrimBOr                :: IntegralType a -> PrimFun ((a, a)   -> a)+  PrimBXor               :: IntegralType a -> PrimFun ((a, a)   -> a)+  PrimBNot               :: IntegralType a -> PrimFun (a        -> a)+  PrimBShiftL            :: IntegralType a -> PrimFun ((a, Int) -> a)+  PrimBShiftR            :: IntegralType a -> PrimFun ((a, Int) -> a)+  PrimBRotateL           :: IntegralType a -> PrimFun ((a, Int) -> a)+  PrimBRotateR           :: IntegralType a -> PrimFun ((a, Int) -> a)+  PrimPopCount           :: IntegralType a -> PrimFun (a -> Int)+  PrimCountLeadingZeros  :: IntegralType a -> PrimFun (a -> Int)+  PrimCountTrailingZeros :: IntegralType a -> PrimFun (a -> Int) +  -- operators from Fractional and Floating   PrimFDiv        :: FloatingType a -> PrimFun ((a, a) -> a)   PrimRecip       :: FloatingType a -> PrimFun (a      -> a)   PrimSin         :: FloatingType a -> PrimFun (a      -> a)@@ -889,6 +1042,9 @@   PrimAsin        :: FloatingType a -> PrimFun (a      -> a)   PrimAcos        :: FloatingType a -> PrimFun (a      -> a)   PrimAtan        :: FloatingType a -> PrimFun (a      -> a)+  PrimSinh        :: FloatingType a -> PrimFun (a      -> a)+  PrimCosh        :: FloatingType a -> PrimFun (a      -> a)+  PrimTanh        :: FloatingType a -> PrimFun (a      -> a)   PrimAsinh       :: FloatingType a -> PrimFun (a      -> a)   PrimAcosh       :: FloatingType a -> PrimFun (a      -> a)   PrimAtanh       :: FloatingType a -> PrimFun (a      -> a)@@ -897,13 +1053,32 @@   PrimLog         :: FloatingType a -> PrimFun (a      -> a)   PrimFPow        :: FloatingType a -> PrimFun ((a, a) -> a)   PrimLogBase     :: FloatingType a -> PrimFun ((a, a) -> a)-  PrimAtan2       :: FloatingType a -> PrimFun ((a, a) -> a)-  PrimTruncate    :: FloatingType a -> IntegralType b -> PrimFun (a -> b)-  PrimRound       :: FloatingType a -> IntegralType b -> PrimFun (a -> b)-  PrimFloor       :: FloatingType a -> IntegralType b -> PrimFun (a -> b)-  PrimCeiling     :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+   -- FIXME: add missing operations from RealFrac & RealFloat +  -- operators from RealFrac+  PrimTruncate :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+  PrimRound    :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+  PrimFloor    :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+  PrimCeiling  :: FloatingType a -> IntegralType b -> PrimFun (a -> b)+  -- PrimProperFraction :: FloatingType a -> IntegralType b -> PrimFun (a -> (b, a))++  -- operators from RealFloat+  PrimIsNaN :: FloatingType a -> PrimFun (a -> Bool)+  PrimAtan2 :: FloatingType a -> PrimFun ((a, a) -> a)+  -- PrimFloatRadix     :: FloatingType a -> PrimFun (a -> Int)         -- Integer?+  -- PrimFloatDigits    :: FloatingType a -> PrimFun (a -> Int)+  -- PrimFloatRange     :: FloatingType a -> PrimFun (a -> (Int, Int))+  -- PrimDecodeFloat    :: FloatingType a -> PrimFun (a -> (Int, Int))  -- Integer?+  -- PrimEncodeFloat    :: FloatingType a -> PrimFun ((Int, Int) -> a)  -- Integer?+  -- PrimExponent       :: FloatingType a -> PrimFun (a -> Int)+  -- PrimSignificand    :: FloatingType a -> PrimFun (a -> a)+  -- PrimScaleFloat     :: FloatingType a -> PrimFun ((Int, a) -> a)+  -- PrimIsInfinite     :: FloatingType a -> PrimFun (a -> Bool)+  -- PrimIsDenormalized :: FloatingType a -> PrimFun (a -> Bool)+  -- PrimIsNegativeZero :: FloatingType a -> PrimFun (a -> Bool)+  -- PrimIsIEEE         :: FloatingType a -> PrimFun (a -> Bool)+   -- relational and equality operators   PrimLt   :: ScalarType a -> PrimFun ((a, a) -> Bool)   PrimGt   :: ScalarType a -> PrimFun ((a, a) -> Bool)@@ -920,21 +1095,382 @@   PrimLNot :: PrimFun (Bool         -> Bool)    -- character conversions+  -- FIXME: use IntegralType?   PrimOrd  :: PrimFun (Char -> Int)   PrimChr  :: PrimFun (Int  -> Char)-  -- FIXME: use IntegralType? -  -- FIXME: conversions between various integer types-  --        should we have an overloaded functions like 'toInt'?-  --        (or 'fromEnum' for enums?)-  PrimBoolToInt    :: PrimFun (Bool -> Int)+  -- boolean conversion+  PrimBoolToInt :: PrimFun (Bool -> Int)++  -- general conversion between types   PrimFromIntegral :: IntegralType a -> NumType b -> PrimFun (a -> b)+  PrimToFloating   :: NumType a -> FloatingType b -> PrimFun (a -> b) -  -- FIXME: what do we want to do about Enum?  succ and pred are only-  --   moderatly useful without user-defined enumerations, but we want-  --   the range constructs for arrays (but that's not scalar primitives)+  -- reinterpret the bits of a value as a different type+  -- (the two types must have the same bit size)+  PrimCoerce :: ScalarType a -> ScalarType b -> PrimFun (a -> b) +  -- FIXME: Conversions between various integer types: should we have overloaded+  -- functions like 'toInt'? (or 'fromEnum' for enums?) +  -- FIXME: What do we want to do about Enum? 'succ' and 'pred' are only+  -- moderately useful without user-defined enumerations, but we want the range+  -- constructs for arrays (but that's not scalar primitives)+++-- NFData instances+-- ================++instance NFData (OpenAfun aenv f) where+  rnf = rnfOpenAfun++instance NFData (OpenAcc aenv t) where+  rnf = rnfOpenAcc++-- instance NFData (Seq t) where+--   rnf = rnfPreOpenSeq rnfOpenAcc++instance NFData (OpenExp env aenv t) where+  rnf = rnfPreOpenExp rnfOpenAcc++instance NFData (OpenFun env aenv t) where+  rnf = rnfPreOpenFun rnfOpenAcc+++-- Array expressions+-- -----------------++type NFDataAcc acc = forall aenv t. acc aenv t -> ()++rnfIdx :: Idx env t -> ()+rnfIdx ZeroIdx      = ()+rnfIdx (SuccIdx ix) = rnfIdx ix++rnfTupleIdx :: TupleIdx t e -> ()+rnfTupleIdx ZeroTupIdx       = ()+rnfTupleIdx (SuccTupIdx tix) = rnfTupleIdx tix++rnfOpenAfun :: OpenAfun aenv t -> ()+rnfOpenAfun = rnfPreOpenAfun rnfOpenAcc++rnfOpenAcc :: OpenAcc aenv t -> ()+rnfOpenAcc (OpenAcc pacc) = rnfPreOpenAcc rnfOpenAcc pacc++rnfPreOpenAfun :: NFDataAcc acc -> PreOpenAfun acc aenv t -> ()+rnfPreOpenAfun rnfA (Abody b) = rnfA b+rnfPreOpenAfun rnfA (Alam f)  = rnfPreOpenAfun rnfA f++rnfPreOpenAcc :: forall acc aenv t. NFDataAcc acc -> PreOpenAcc acc aenv t -> ()+rnfPreOpenAcc rnfA pacc =+  let+      rnfAF :: PreOpenAfun acc aenv' t' -> ()+      rnfAF = rnfPreOpenAfun rnfA++      rnfE :: PreOpenExp acc env' aenv' t' -> ()+      rnfE = rnfPreOpenExp rnfA++      rnfF :: PreOpenFun acc env' aenv' t' -> ()+      rnfF = rnfPreOpenFun rnfA++      -- rnfS :: PreOpenSeq acc aenv' senv' t' -> ()+      -- rnfS = rnfPreOpenSeq rnfA++      rnfB :: forall aenv' sh e. Elt e => acc aenv' (Array sh e) -> Boundary (EltRepr e) -> ()+      rnfB _ = rnfBoundary (eltType (undefined::e))+  in+  case pacc of+    Alet bnd body             -> rnfA bnd `seq` rnfA body+    Avar ix                   -> rnfIdx ix+    Atuple atup               -> rnfAtuple rnfA atup+    Aprj tix a                -> rnfTupleIdx tix `seq` rnfA a+    Apply afun acc            -> rnfAF afun `seq` rnfA acc+    Aforeign asm afun a       -> rnf (strForeign asm) `seq` rnfAF afun `seq` rnfA a+    Acond p a1 a2             -> rnfE p `seq` rnfA a1 `seq` rnfA a2+    Awhile p f a              -> rnfAF p `seq` rnfAF f `seq` rnfA a+    Use arrs                  -> rnfArrays (arrays (undefined::t)) arrs+    Unit x                    -> rnfE x+    Reshape sh a              -> rnfE sh `seq` rnfA a+    Generate sh f             -> rnfE sh `seq` rnfF f+    Transform sh p f a        -> rnfE sh `seq` rnfF p `seq` rnfF f `seq` rnfA a+    Replicate slice sh a      -> rnfSliceIndex slice `seq` rnfE sh `seq` rnfA a+    Slice slice a sh          -> rnfSliceIndex slice `seq` rnfE sh `seq` rnfA a+    Map f a                   -> rnfF f `seq` rnfA a+    ZipWith f a1 a2           -> rnfF f `seq` rnfA a1 `seq` rnfA a2+    Fold f z a                -> rnfF f `seq` rnfE z `seq` rnfA a+    Fold1 f a                 -> rnfF f `seq` rnfA a+    FoldSeg f z a s           -> rnfF f `seq` rnfE z `seq` rnfA a `seq` rnfA s+    Fold1Seg f a s            -> rnfF f `seq` rnfA a `seq` rnfA s+    Scanl f z a               -> rnfF f `seq` rnfE z `seq` rnfA a+    Scanl1 f a                -> rnfF f `seq` rnfA a+    Scanl' f z a              -> rnfF f `seq` rnfE z `seq` rnfA a+    Scanr f z a               -> rnfF f `seq` rnfE z `seq` rnfA a+    Scanr1 f a                -> rnfF f `seq` rnfA a+    Scanr' f z a              -> rnfF f `seq` rnfE z `seq` rnfA a+    Permute f d p a           -> rnfF f `seq` rnfA d `seq` rnfF p `seq` rnfA a+    Backpermute sh f a        -> rnfE sh `seq` rnfF f `seq` rnfA a+    Stencil f b a             -> rnfF f `seq` rnfB a b `seq` rnfA a+    Stencil2 f b1 a1 b2 a2    -> rnfF f `seq` rnfB a1 b1 `seq` rnfB a2 b2 `seq` rnfA a1 `seq` rnfA a2+    -- Collect s                 -> rnfS s+++rnfAtuple :: NFDataAcc acc -> Atuple (acc aenv) t -> ()+rnfAtuple _    NilAtup          = ()+rnfAtuple rnfA (SnocAtup tup a) = rnfAtuple rnfA tup `seq` rnfA a++rnfArrays :: ArraysR arrs -> arrs -> ()+rnfArrays ArraysRunit           ()      = ()+rnfArrays ArraysRarray          arr     = rnf arr+rnfArrays (ArraysRpair ar1 ar2) (a1,a2) = rnfArrays ar1 a1 `seq` rnfArrays ar2 a2++rnfBoundary :: TupleType t -> Boundary t -> ()+rnfBoundary _ Clamp        = ()+rnfBoundary _ Mirror       = ()+rnfBoundary _ Wrap         = ()+rnfBoundary t (Constant c) = rnfConst t c+++{--+-- Sequence expressions+-- --------------------++rnfPreOpenSeq :: forall acc aenv senv t. NFDataAcc acc -> PreOpenSeq acc aenv senv t -> ()+rnfPreOpenSeq rnfA topSeq =+  let+      rnfS :: PreOpenSeq acc aenv' senv' t' -> ()+      rnfS = rnfPreOpenSeq rnfA++      rnfP :: Producer acc aenv' senv' t' -> ()+      rnfP = rnfSeqProducer rnfA++      rnfC :: Consumer acc aenv' senv' t' -> ()+      rnfC = rnfSeqConsumer rnfA+  in+  case topSeq of+    Producer p s              -> rnfP p `seq` rnfS s+    Consumer c                -> rnfC c+    Reify ix                  -> rnfIdx ix++rnfSeqProducer :: forall acc aenv senv t. NFDataAcc acc -> Producer acc aenv senv t -> ()+rnfSeqProducer rnfA topSeq =+  let+      rnfArrs :: forall a. Arrays a => [a] -> ()+      rnfArrs []     = ()+      rnfArrs (a:as) = rnfArrays (arrays (undefined::a)) (fromArr a) `seq` rnfArrs as++      rnfAF :: PreOpenAfun acc aenv' t' -> ()+      rnfAF = rnfPreOpenAfun rnfA++      rnfF :: PreOpenFun acc env' aenv' t' -> ()+      rnfF = rnfPreOpenFun rnfA++      rnfE :: PreOpenExp acc env' aenv' t' -> ()+      rnfE = rnfPreOpenExp rnfA+  in+  case topSeq of+    StreamIn as               -> rnfArrs as+    ToSeq slice _ a           -> rnfSliceIndex slice `seq` rnfA a+    MapSeq f ix               -> rnfAF f `seq` rnfIdx ix+    ChunkedMapSeq f ix        -> rnfAF f `seq` rnfIdx ix+    ZipWithSeq f ix1 ix2      -> rnfAF f `seq` rnfIdx ix1 `seq` rnfIdx ix2+    ScanSeq f z ix            -> rnfF f `seq` rnfE z `seq` rnfIdx ix++rnfSeqConsumer :: forall acc aenv senv t. NFDataAcc acc -> Consumer acc aenv senv t -> ()+rnfSeqConsumer rnfA topSeq =+  let+      rnfAF :: PreOpenAfun acc aenv' t' -> ()+      rnfAF = rnfPreOpenAfun rnfA++      rnfF :: PreOpenFun acc env' aenv' t' -> ()+      rnfF = rnfPreOpenFun rnfA++      rnfE :: PreOpenExp acc env' aenv' t' -> ()+      rnfE = rnfPreOpenExp rnfA+  in+  case topSeq of+    FoldSeq f z ix            -> rnfF f `seq` rnfE z `seq` rnfIdx ix+    FoldSeqFlatten f a ix     -> rnfAF f `seq` rnfA a `seq` rnfIdx ix+    Stuple stup               -> rnfStuple rnfA stup++rnfStuple :: NFDataAcc acc -> Atuple (Consumer acc aenv senv) t -> ()+rnfStuple _    NilAtup          = ()+rnfStuple rnfA (SnocAtup tup c) = rnfStuple rnfA tup `seq` rnfSeqConsumer rnfA c+--}++-- Scalar expressions+-- ------------------++rnfPreOpenFun :: NFDataAcc acc -> PreOpenFun acc env aenv t -> ()+rnfPreOpenFun rnfA (Body b) = rnfPreOpenExp rnfA b+rnfPreOpenFun rnfA (Lam f)  = rnfPreOpenFun rnfA f++rnfPreOpenExp :: forall acc env aenv t. NFDataAcc acc -> PreOpenExp acc env aenv t -> ()+rnfPreOpenExp rnfA topExp =+  let+      rnfF :: PreOpenFun acc env' aenv' t' -> ()+      rnfF = rnfPreOpenFun rnfA++      rnfE :: PreOpenExp acc env' aenv' t' -> ()+      rnfE = rnfPreOpenExp rnfA+  in+  case topExp of+    Let bnd body              -> rnfE bnd `seq` rnfE body+    Var ix                    -> rnfIdx ix+    Foreign asm f x           -> rnf (strForeign asm) `seq` rnfF f `seq` rnfE x+    Const t                   -> rnfConst (eltType (undefined::t)) t+    Tuple t                   -> rnfTuple rnfA t+    Prj ix e                  -> rnfTupleIdx ix `seq` rnfE e+    IndexNil                  -> ()+    IndexCons sh sz           -> rnfE sh `seq` rnfE sz+    IndexHead sh              -> rnfE sh+    IndexTail sh              -> rnfE sh+    IndexAny                  -> ()+    IndexSlice slice slix sh  -> rnfSliceIndex slice `seq` rnfE slix `seq` rnfE sh+    IndexFull slice slix sl   -> rnfSliceIndex slice `seq` rnfE slix `seq` rnfE sl+    ToIndex sh ix             -> rnfE sh `seq` rnfE ix+    FromIndex sh ix           -> rnfE sh `seq` rnfE ix+    Cond p e1 e2              -> rnfE p `seq` rnfE e1 `seq` rnfE e2+    While p f x               -> rnfF p `seq` rnfF f `seq` rnfE x+    PrimConst c               -> rnfPrimConst c+    PrimApp f x               -> rnfPrimFun f `seq` rnfE x+    Index a ix                -> rnfA a `seq` rnfE ix+    LinearIndex a ix          -> rnfA a `seq` rnfE ix+    Shape a                   -> rnfA a+    ShapeSize sh              -> rnfE sh+    Intersect sh1 sh2         -> rnfE sh1 `seq` rnfE sh2+    Union sh1 sh2             -> rnfE sh1 `seq` rnfE sh2++rnfTuple :: NFDataAcc acc -> Tuple (PreOpenExp acc env aenv) t -> ()+rnfTuple _    NilTup        = ()+rnfTuple rnfA (SnocTup t e) = rnfTuple rnfA t `seq` rnfPreOpenExp rnfA e++rnfConst :: TupleType t -> t -> ()+rnfConst UnitTuple          ()    = ()+rnfConst (SingleTuple t)    !_    = rnfScalarType t  -- scalars should have (nf == whnf)+rnfConst (PairTuple ta tb)  (a,b) = rnfConst ta a `seq` rnfConst tb b++rnfPrimConst :: PrimConst c -> ()+rnfPrimConst (PrimMinBound t) = rnfBoundedType t+rnfPrimConst (PrimMaxBound t) = rnfBoundedType t+rnfPrimConst (PrimPi t)       = rnfFloatingType t++rnfPrimFun :: PrimFun f -> ()+rnfPrimFun (PrimAdd t)                = rnfNumType t+rnfPrimFun (PrimSub t)                = rnfNumType t+rnfPrimFun (PrimMul t)                = rnfNumType t+rnfPrimFun (PrimNeg t)                = rnfNumType t+rnfPrimFun (PrimAbs t)                = rnfNumType t+rnfPrimFun (PrimSig t)                = rnfNumType t+rnfPrimFun (PrimQuot t)               = rnfIntegralType t+rnfPrimFun (PrimRem t)                = rnfIntegralType t+rnfPrimFun (PrimQuotRem t)            = rnfIntegralType t+rnfPrimFun (PrimIDiv t)               = rnfIntegralType t+rnfPrimFun (PrimMod t)                = rnfIntegralType t+rnfPrimFun (PrimDivMod t)             = rnfIntegralType t+rnfPrimFun (PrimBAnd t)               = rnfIntegralType t+rnfPrimFun (PrimBOr t)                = rnfIntegralType t+rnfPrimFun (PrimBXor t)               = rnfIntegralType t+rnfPrimFun (PrimBNot t)               = rnfIntegralType t+rnfPrimFun (PrimBShiftL t)            = rnfIntegralType t+rnfPrimFun (PrimBShiftR t)            = rnfIntegralType t+rnfPrimFun (PrimBRotateL t)           = rnfIntegralType t+rnfPrimFun (PrimBRotateR t)           = rnfIntegralType t+rnfPrimFun (PrimPopCount t)           = rnfIntegralType t+rnfPrimFun (PrimCountLeadingZeros t)  = rnfIntegralType t+rnfPrimFun (PrimCountTrailingZeros t) = rnfIntegralType t+rnfPrimFun (PrimFDiv t)               = rnfFloatingType t+rnfPrimFun (PrimRecip t)              = rnfFloatingType t+rnfPrimFun (PrimSin t)                = rnfFloatingType t+rnfPrimFun (PrimCos t)                = rnfFloatingType t+rnfPrimFun (PrimTan t)                = rnfFloatingType t+rnfPrimFun (PrimAsin t)               = rnfFloatingType t+rnfPrimFun (PrimAcos t)               = rnfFloatingType t+rnfPrimFun (PrimAtan t)               = rnfFloatingType t+rnfPrimFun (PrimSinh t)               = rnfFloatingType t+rnfPrimFun (PrimCosh t)               = rnfFloatingType t+rnfPrimFun (PrimTanh t)               = rnfFloatingType t+rnfPrimFun (PrimAsinh t)              = rnfFloatingType t+rnfPrimFun (PrimAcosh t)              = rnfFloatingType t+rnfPrimFun (PrimAtanh t)              = rnfFloatingType t+rnfPrimFun (PrimExpFloating t)        = rnfFloatingType t+rnfPrimFun (PrimSqrt t)               = rnfFloatingType t+rnfPrimFun (PrimLog t)                = rnfFloatingType t+rnfPrimFun (PrimFPow t)               = rnfFloatingType t+rnfPrimFun (PrimLogBase t)            = rnfFloatingType t+rnfPrimFun (PrimTruncate f i)         = rnfFloatingType f `seq` rnfIntegralType i+rnfPrimFun (PrimRound f i)            = rnfFloatingType f `seq` rnfIntegralType i+rnfPrimFun (PrimFloor f i)            = rnfFloatingType f `seq` rnfIntegralType i+rnfPrimFun (PrimCeiling f i)          = rnfFloatingType f `seq` rnfIntegralType i+rnfPrimFun (PrimIsNaN t)              = rnfFloatingType t+rnfPrimFun (PrimAtan2 t)              = rnfFloatingType t+rnfPrimFun (PrimLt t)                 = rnfScalarType t+rnfPrimFun (PrimGt t)                 = rnfScalarType t+rnfPrimFun (PrimLtEq t)               = rnfScalarType t+rnfPrimFun (PrimGtEq t)               = rnfScalarType t+rnfPrimFun (PrimEq t)                 = rnfScalarType t+rnfPrimFun (PrimNEq t)                = rnfScalarType t+rnfPrimFun (PrimMax t)                = rnfScalarType t+rnfPrimFun (PrimMin t)                = rnfScalarType t+rnfPrimFun PrimLAnd                   = ()+rnfPrimFun PrimLOr                    = ()+rnfPrimFun PrimLNot                   = ()+rnfPrimFun PrimOrd                    = ()+rnfPrimFun PrimChr                    = ()+rnfPrimFun PrimBoolToInt              = ()+rnfPrimFun (PrimFromIntegral i n)     = rnfIntegralType i `seq` rnfNumType n+rnfPrimFun (PrimToFloating n f)       = rnfNumType n `seq` rnfFloatingType f+rnfPrimFun (PrimCoerce a b)           = rnfScalarType a `seq` rnfScalarType b++rnfSliceIndex :: SliceIndex ix slice co sh -> ()+rnfSliceIndex SliceNil        = ()+rnfSliceIndex (SliceAll sh)   = rnfSliceIndex sh+rnfSliceIndex (SliceFixed sh) = rnfSliceIndex sh++rnfScalarType :: ScalarType t -> ()+rnfScalarType (NumScalarType t)    = rnfNumType t+rnfScalarType (NonNumScalarType t) = rnfNonNumType t++rnfBoundedType :: BoundedType t -> ()+rnfBoundedType (IntegralBoundedType t) = rnfIntegralType t+rnfBoundedType (NonNumBoundedType t)   = rnfNonNumType t++rnfNumType :: NumType t -> ()+rnfNumType (IntegralNumType t) = rnfIntegralType t+rnfNumType (FloatingNumType t) = rnfFloatingType t++rnfNonNumType :: NonNumType t -> ()+rnfNonNumType (TypeBool   NonNumDict) = ()+rnfNonNumType (TypeChar   NonNumDict) = ()+rnfNonNumType (TypeCChar  NonNumDict) = ()+rnfNonNumType (TypeCSChar NonNumDict) = ()+rnfNonNumType (TypeCUChar NonNumDict) = ()++rnfIntegralType :: IntegralType t -> ()+rnfIntegralType (TypeInt     IntegralDict) = ()+rnfIntegralType (TypeInt8    IntegralDict) = ()+rnfIntegralType (TypeInt16   IntegralDict) = ()+rnfIntegralType (TypeInt32   IntegralDict) = ()+rnfIntegralType (TypeInt64   IntegralDict) = ()+rnfIntegralType (TypeWord    IntegralDict) = ()+rnfIntegralType (TypeWord8   IntegralDict) = ()+rnfIntegralType (TypeWord16  IntegralDict) = ()+rnfIntegralType (TypeWord32  IntegralDict) = ()+rnfIntegralType (TypeWord64  IntegralDict) = ()+rnfIntegralType (TypeCShort  IntegralDict) = ()+rnfIntegralType (TypeCUShort IntegralDict) = ()+rnfIntegralType (TypeCInt    IntegralDict) = ()+rnfIntegralType (TypeCUInt   IntegralDict) = ()+rnfIntegralType (TypeCLong   IntegralDict) = ()+rnfIntegralType (TypeCULong  IntegralDict) = ()+rnfIntegralType (TypeCLLong  IntegralDict) = ()+rnfIntegralType (TypeCULLong IntegralDict) = ()++rnfFloatingType :: FloatingType t -> ()+rnfFloatingType (TypeFloat   FloatingDict) = ()+rnfFloatingType (TypeDouble  FloatingDict) = ()+rnfFloatingType (TypeCFloat  FloatingDict) = ()+rnfFloatingType (TypeCDouble FloatingDict) = ()++ -- Debugging -- --------- @@ -970,6 +1506,7 @@ showPreAccOp Backpermute{}      = "Backpermute" showPreAccOp Stencil{}          = "Stencil" showPreAccOp Stencil2{}         = "Stencil2"+-- showPreAccOp Collect{}          = "Collect"  showArrays :: forall arrs. Arrays arrs => arrs -> String showArrays = display . collect (arrays (undefined::arrs)) . fromArr@@ -1017,4 +1554,5 @@ showPreExpOp Shape{}            = "Shape" showPreExpOp ShapeSize{}        = "ShapeSize" showPreExpOp Intersect{}        = "Intersect"+showPreExpOp Union{}            = "Union" 

@@ -7,1038 +7,1217 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Analysis.Match--- Copyright   : [2012..2014] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.Analysis.Match (--  -- matching expressions-  MatchAcc,-  (:=:)(..),-  matchOpenAcc,  matchPreOpenAcc,-  matchOpenAfun, matchPreOpenAfun,-  matchOpenExp,  matchPreOpenExp,-  matchOpenFun,  matchPreOpenFun,-  matchPrimFun,  matchPrimFun',--  -- auxiliary-  matchIdx, matchTupleType,-  matchIntegralType, matchFloatingType, matchNumType, matchScalarType,--  -- hashing expressions-  HashAcc,-  hashPreOpenAcc, hashOpenAcc,-  hashPreOpenExp, hashOpenExp,-  hashPreOpenFun,--) where---- standard library-import Prelude                                          hiding ( exp )-import Data.Maybe-import Data.Typeable-import Data.Hashable-import System.Mem.StableName-import System.IO.Unsafe                                 ( unsafePerformIO )---- friends-import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Array.Representation       ( SliceIndex(..) )-import Data.Array.Accelerate.Tuple                      hiding ( Tuple )-import qualified Data.Array.Accelerate.Tuple            as Tuple----- Witness equality between types. A value of a :=: b is a proof that types a--- and b are equal. By pattern matching on REFL this fact is introduced to the--- type checker.----data s :=: t where-  REFL :: s :=: s--deriving instance Show (s :=: t)----- The type of matching array computations----type MatchAcc acc = forall aenv s t. acc aenv s -> acc aenv t -> Maybe (s :=: t)----- Compute the congruence of two array computations. The nodes are congruent if--- they have the same operator and their operands are congruent.----matchOpenAcc :: OpenAcc aenv s -> OpenAcc aenv t -> Maybe (s :=: t)-matchOpenAcc (OpenAcc acc1) (OpenAcc acc2) =-  matchPreOpenAcc matchOpenAcc hashOpenAcc acc1 acc2---matchPreOpenAcc-    :: forall acc aenv s t.-       MatchAcc acc-    -> HashAcc  acc-    -> PreOpenAcc acc aenv s-    -> PreOpenAcc acc aenv t-    -> Maybe (s :=: t)-matchPreOpenAcc matchAcc hashAcc = match-  where-    matchFun :: PreOpenFun acc env' aenv' u -> PreOpenFun acc env' aenv' v -> Maybe (u :=: v)-    matchFun = matchPreOpenFun matchAcc hashAcc--    matchExp :: PreOpenExp acc env' aenv' u -> PreOpenExp acc env' aenv' v -> Maybe (u :=: v)-    matchExp = matchPreOpenExp matchAcc hashAcc--    match :: PreOpenAcc acc aenv s -> PreOpenAcc acc aenv t -> Maybe (s :=: t)-    match (Alet x1 a1) (Alet x2 a2)-      | Just REFL <- matchAcc x1 x2-      , Just REFL <- matchAcc a1 a2-      = Just REFL--    match (Avar v1) (Avar v2)-      = matchIdx v1 v2--    match (Atuple t1) (Atuple t2)-      | Just REFL <- matchAtuple matchAcc t1 t2-      = gcast REFL  -- surface/representation type--    match (Aprj ix1 t1) (Aprj ix2 t2)-      | Just REFL <- matchAcc t1 t2-      , Just REFL <- matchTupleIdx ix1 ix2-      = Just REFL--    match (Apply f1 a1) (Apply f2 a2)-      | Just REFL <- matchPreOpenAfun matchAcc f1 f2-      , Just REFL <- matchAcc                  a1 a2-      = Just REFL--    match (Aforeign ff1 _ a1) (Aforeign ff2 _ a2)-      | Just REFL <- matchAcc a1 a2-      , unsafePerformIO $ do-          sn1 <- makeStableName ff1-          sn2 <- makeStableName ff2-          return $! hashStableName sn1 == hashStableName sn2-      = gcast REFL--    match (Acond p1 t1 e1) (Acond p2 t2 e2)-      | Just REFL <- matchExp p1 p2-      , Just REFL <- matchAcc t1 t2-      , Just REFL <- matchAcc e1 e2-      = Just REFL--    match (Awhile p1 f1 a1) (Awhile p2 f2 a2)-      | Just REFL <- matchAcc a1 a2-      , Just REFL <- matchPreOpenAfun matchAcc p1 p2-      , Just REFL <- matchPreOpenAfun matchAcc f1 f2-      = Just REFL--    match (Use a1) (Use a2)-      | Just REFL <- matchArrays (arrays (undefined::s)) (arrays (undefined::t)) a1 a2-      = gcast REFL--    match (Unit e1) (Unit e2)-      | Just REFL <- matchExp e1 e2-      = Just REFL--    match (Reshape sh1 a1) (Reshape sh2 a2)-      | Just REFL <- matchExp sh1 sh2-      , Just REFL <- matchAcc a1  a2-      = Just REFL--    match (Generate sh1 f1) (Generate sh2 f2)-      | Just REFL <- matchExp sh1 sh2-      , Just REFL <- matchFun f1  f2-      = Just REFL--    match (Transform sh1 ix1 f1 a1) (Transform sh2 ix2 f2 a2)-      | Just REFL <- matchExp sh1 sh2-      , Just REFL <- matchFun ix1 ix2-      , Just REFL <- matchFun f1  f2-      , Just REFL <- matchAcc a1  a2-      = Just REFL--    match (Replicate _ ix1 a1) (Replicate _ ix2 a2)-      | Just REFL <- matchExp ix1 ix2-      , Just REFL <- matchAcc a1  a2-      = gcast REFL  -- slice specification ??--    match (Slice _ a1 ix1) (Slice _ a2 ix2)-      | Just REFL <- matchAcc a1  a2-      , Just REFL <- matchExp ix1 ix2-      = gcast REFL  -- slice specification ??--    match (Map f1 a1) (Map f2 a2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchAcc a1 a2-      = Just REFL--    match (ZipWith f1 a1 b1) (ZipWith f2 a2 b2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchAcc a1 a2-      , Just REFL <- matchAcc b1 b2-      = Just REFL--    match (Fold f1 z1 a1) (Fold f2 z2 a2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchExp z1 z2-      , Just REFL <- matchAcc a1 a2-      = Just REFL--    match (Fold1 f1 a1) (Fold1 f2 a2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchAcc a1 a2-      = Just REFL--    match (FoldSeg f1 z1 a1 s1) (FoldSeg f2 z2 a2 s2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchExp z1 z2-      , Just REFL <- matchAcc a1 a2-      , Just REFL <- matchAcc s1 s2-      = Just REFL--    match (Fold1Seg f1 a1 s1) (Fold1Seg f2 a2 s2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchAcc a1 a2-      , Just REFL <- matchAcc s1 s2-      = Just REFL--    match (Scanl f1 z1 a1) (Scanl f2 z2 a2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchExp z1 z2-      , Just REFL <- matchAcc a1 a2-      = Just REFL--    match (Scanl' f1 z1 a1) (Scanl' f2 z2 a2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchExp z1 z2-      , Just REFL <- matchAcc a1 a2-      = Just REFL--    match (Scanl1 f1 a1) (Scanl1 f2 a2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchAcc a1 a2-      = Just REFL--    match (Scanr f1 z1 a1) (Scanr f2 z2 a2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchExp z1 z2-      , Just REFL <- matchAcc a1 a2-      = Just REFL--    match (Scanr' f1 z1 a1) (Scanr' f2 z2 a2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchExp z1 z2-      , Just REFL <- matchAcc a1 a2-      = Just REFL--    match (Scanr1 f1 a1) (Scanr1 f2 a2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchAcc a1 a2-      = Just REFL--    match (Permute f1 d1 p1 a1) (Permute f2 d2 p2 a2)-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchAcc d1 d2-      , Just REFL <- matchFun p1 p2-      , Just REFL <- matchAcc a1 a2-      = Just REFL--    match (Backpermute sh1 ix1 a1) (Backpermute sh2 ix2 a2)-      | Just REFL <- matchExp sh1 sh2-      , Just REFL <- matchFun ix1 ix2-      , Just REFL <- matchAcc a1  a2-      = Just REFL--    match (Stencil f1 b1 (a1 :: acc aenv (Array sh1 e1)))-          (Stencil f2 b2 (a2 :: acc aenv (Array sh2 e2)))-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchAcc a1 a2-      , matchBoundary (eltType (undefined::e1)) b1 b2-      = Just REFL--    match (Stencil2 f1 b1  (a1  :: acc aenv (Array sh1  e1 )) b2  (a2 :: acc aenv (Array sh2  e2 )))-          (Stencil2 f2 b1' (a1' :: acc aenv (Array sh1' e1')) b2' (a2':: acc aenv (Array sh2' e2')))-      | Just REFL <- matchFun f1 f2-      , Just REFL <- matchAcc a1 a1'-      , Just REFL <- matchAcc a2 a2'-      , matchBoundary (eltType (undefined::e1)) b1 b1'-      , matchBoundary (eltType (undefined::e2)) b2 b2'-      = Just REFL--    match _ _-      = Nothing----- Array tuples----matchAtuple-    :: MatchAcc acc-    -> Atuple (acc aenv) s-    -> Atuple (acc aenv) t-    -> Maybe (s :=: t)-matchAtuple matchAcc (SnocAtup t1 a1) (SnocAtup t2 a2)-  | Just REFL <- matchAtuple matchAcc t1 t2-  , Just REFL <- matchAcc             a1 a2-  = Just REFL--matchAtuple _ NilAtup NilAtup = Just REFL-matchAtuple _ _       _       = Nothing----- Array functions----matchOpenAfun :: OpenAfun aenv s -> OpenAfun aenv t -> Maybe (s :=: t)-matchOpenAfun = matchPreOpenAfun matchOpenAcc--matchPreOpenAfun :: MatchAcc acc -> PreOpenAfun acc aenv s -> PreOpenAfun acc aenv t -> Maybe (s :=: t)-matchPreOpenAfun m (Alam s) (Alam t)-  | Just REFL <- matchEnvTop        s t-  , Just REFL <- matchPreOpenAfun m s t-  = Just REFL-  where-    matchEnvTop :: (Arrays s, Arrays t)-                => PreOpenAfun acc (aenv, s) f -> PreOpenAfun acc (aenv, t) g -> Maybe (s :=: t)-    matchEnvTop _ _ = gcast REFL  -- ???--matchPreOpenAfun m (Abody s) (Abody t) = m s t-matchPreOpenAfun _ _         _         = Nothing----- Match stencil boundaries----matchBoundary :: TupleType e -> Boundary e -> Boundary e -> Bool-matchBoundary ty (Constant s) (Constant t) = matchConst ty s t-matchBoundary _  Wrap         Wrap         = True-matchBoundary _  Clamp        Clamp        = True-matchBoundary _  Mirror       Mirror       = True-matchBoundary _  _            _            = False----- Match arrays------ As a convenience, we are just comparing the stable names, but we could also--- walk the structure comparing the underlying ptrsOfArrayData.----matchArrays :: ArraysR s -> ArraysR t -> s -> t -> Maybe (s :=: t)-matchArrays ArraysRunit ArraysRunit () ()-  = Just REFL--matchArrays (ArraysRpair a1 b1) (ArraysRpair a2 b2) (arr1,brr1) (arr2,brr2)-  | Just REFL <- matchArrays a1 a2 arr1 arr2-  , Just REFL <- matchArrays b1 b2 brr1 brr2-  = Just REFL--matchArrays ArraysRarray ArraysRarray (Array _ ad1) (Array _ ad2)-  | unsafePerformIO $ do-      sn1 <- makeStableName ad1-      sn2 <- makeStableName ad2-      return $! hashStableName sn1 == hashStableName sn2-  = gcast REFL--matchArrays _ _ _ _-  = Nothing----- Compute the congruence of two scalar expressions. Two nodes are congruent if--- either:------  1. The nodes label constants and the contents are equal---  2. They have the same operator and their operands are congruent------ The below attempts to use real typed equality, but occasionally still needs--- to use a cast, particularly when we can only match the representation types.----matchOpenExp :: OpenExp env aenv s -> OpenExp env aenv t -> Maybe (s :=: t)-matchOpenExp = matchPreOpenExp matchOpenAcc hashOpenAcc--matchPreOpenExp-    :: forall acc env aenv s t.-       MatchAcc acc-    -> HashAcc  acc-    -> PreOpenExp acc env aenv s-    -> PreOpenExp acc env aenv t-    -> Maybe (s :=: t)-matchPreOpenExp matchAcc hashAcc = match-  where-    match :: forall env' aenv' s' t'. PreOpenExp acc env' aenv' s' -> PreOpenExp acc env' aenv' t' -> Maybe (s' :=: t')-    match (Let x1 e1) (Let x2 e2)-      | Just REFL <- match x1 x2-      , Just REFL <- match e1 e2-      = Just REFL--    match (Var v1) (Var v2)-      = matchIdx v1 v2--    match (Foreign ff1 _ e1) (Foreign ff2 _ e2)-      | Just REFL <- match e1 e2-      , unsafePerformIO $ do-          sn1 <- makeStableName ff1-          sn2 <- makeStableName ff2-          return $! hashStableName sn1 == hashStableName sn2-      = gcast REFL--    match (Const c1) (Const c2)-      | Just REFL <- matchTupleType (eltType (undefined::s')) (eltType (undefined::t'))-      , matchConst (eltType (undefined::s')) c1 c2-      = gcast REFL  -- surface/representation type--    match (Tuple t1) (Tuple t2)-      | Just REFL <- matchTuple matchAcc hashAcc t1 t2-      = gcast REFL  -- surface/representation type--    match (Prj ix1 t1) (Prj ix2 t2)-      | Just REFL <- match         t1  t2-      , Just REFL <- matchTupleIdx ix1 ix2-      = Just REFL--    match IndexAny IndexAny-      = gcast REFL  -- ???--    match IndexNil IndexNil-      = Just REFL--    match (IndexCons sl1 a1) (IndexCons sl2 a2)-      | Just REFL <- match sl1 sl2-      , Just REFL <- match a1 a2-      = Just REFL--    match (IndexHead sl1) (IndexHead sl2)-      | Just REFL <- match sl1 sl2-      = Just REFL--    match (IndexTail sl1) (IndexTail sl2)-      | Just REFL <- match sl1 sl2-      = Just REFL--    match (IndexSlice sliceIndex1 ix1 sh1) (IndexSlice sliceIndex2 ix2 sh2)-      | Just REFL <- match ix1 ix2-      , Just REFL <- match sh1 sh2-      , Just REFL <- matchSliceRestrict sliceIndex1 sliceIndex2-      = gcast REFL  -- SliceIndex representation/surface type--    match (IndexFull sliceIndex1 ix1 sl1) (IndexFull sliceIndex2 ix2 sl2)-      | Just REFL <- match ix1 ix2-      , Just REFL <- match sl1 sl2-      , Just REFL <- matchSliceExtend sliceIndex1 sliceIndex2-      = gcast REFL  -- SliceIndex representation/surface type--    match (ToIndex sh1 i1) (ToIndex sh2 i2)-      | Just REFL <- match sh1 sh2-      , Just REFL <- match i1  i2-      = Just REFL--    match (FromIndex sh1 i1) (FromIndex sh2 i2)-      | Just REFL <- match i1  i2-      , Just REFL <- match sh1 sh2-      = Just REFL--    match (Cond p1 t1 e1) (Cond p2 t2 e2)-      | Just REFL <- match p1 p2-      , Just REFL <- match t1 t2-      , Just REFL <- match e1 e2-      = Just REFL--    match (While p1 f1 x1) (While p2 f2 x2)-      | Just REFL <- match x1 x2-      , Just REFL <- matchPreOpenFun matchAcc hashAcc p1 p2-      , Just REFL <- matchPreOpenFun matchAcc hashAcc f1 f2-      = Just REFL--    match (PrimConst c1) (PrimConst c2)-      = matchPrimConst c1 c2--    match (PrimApp f1 x1) (PrimApp f2 x2)-      | Just x1'  <- commutes hashAcc f1 x1-      , Just x2'  <- commutes hashAcc f2 x2-      , Just REFL <- match        x1' x2'-      , Just REFL <- matchPrimFun f1  f2-      = Just REFL--      | Just REFL <- match x1 x2-      , Just REFL <- matchPrimFun f1 f2-      = Just REFL--    match (Index a1 x1) (Index a2 x2)-      | Just REFL <- matchAcc a1 a2     -- should only be array indices-      , Just REFL <- match    x1 x2-      = Just REFL--    match (LinearIndex a1 x1) (LinearIndex a2 x2)-      | Just REFL <- matchAcc a1 a2-      , Just REFL <- match    x1 x2-      = Just REFL--    match (Shape a1) (Shape a2)-      | Just REFL <- matchAcc a1 a2     -- should only be array indices-      = Just REFL--    match (ShapeSize sh1) (ShapeSize sh2)-      | Just REFL <- match sh1 sh2-      = Just REFL--    match (Intersect sa1 sb1) (Intersect sa2 sb2)-      | Just REFL <- match sa1 sa2-      , Just REFL <- match sb1 sb2-      = Just REFL--    match _ _-      = Nothing----- Match scalar functions----matchOpenFun :: OpenFun env aenv s -> OpenFun env aenv t -> Maybe (s :=: t)-matchOpenFun = matchPreOpenFun matchOpenAcc hashOpenAcc--matchPreOpenFun-    :: MatchAcc acc-    -> HashAcc  acc-    -> PreOpenFun acc env aenv s-    -> PreOpenFun acc env aenv t-    -> Maybe (s :=: t)-matchPreOpenFun m h (Lam s) (Lam t)-  | Just REFL <- matchEnvTop         s t-  , Just REFL <- matchPreOpenFun m h s t-  = Just REFL-  where-    matchEnvTop :: (Elt s, Elt t) => PreOpenFun acc (env, s) aenv f -> PreOpenFun acc (env, t) aenv g -> Maybe (s :=: t)-    matchEnvTop _ _ = gcast REFL  -- ???--matchPreOpenFun m h (Body s) (Body t) = matchPreOpenExp m h s t-matchPreOpenFun _ _ _        _        = Nothing---- Matching constants----matchConst :: TupleType a -> a -> a -> Bool-matchConst UnitTuple         ()      ()      = True-matchConst (SingleTuple ty)  a       b       = evalEq ty (a,b)-matchConst (PairTuple ta tb) (a1,b1) (a2,b2) = matchConst ta a1 a2 && matchConst tb b1 b2--evalEq :: ScalarType a -> (a, a) -> Bool-evalEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (==)-evalEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (==)-evalEq (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (==)----- Environment projection indices----matchIdx :: Idx env s -> Idx env t -> Maybe (s :=: t)-matchIdx ZeroIdx     ZeroIdx     = Just REFL-matchIdx (SuccIdx u) (SuccIdx v) = matchIdx u v-matchIdx _           _           = Nothing----- Tuple projection indices. Given the same tuple expression structure (tup),--- check that the indices project identical elements.----matchTupleIdx :: TupleIdx tup s -> TupleIdx tup t -> Maybe (s :=: t)-matchTupleIdx ZeroTupIdx     ZeroTupIdx     = Just REFL-matchTupleIdx (SuccTupIdx s) (SuccTupIdx t) = matchTupleIdx s t-matchTupleIdx _              _              = Nothing---- Tuples----matchTuple-    :: MatchAcc acc-    -> HashAcc  acc-    -> Tuple.Tuple (PreOpenExp acc env aenv) s-    -> Tuple.Tuple (PreOpenExp acc env aenv) t-    -> Maybe (s :=: t)-matchTuple _ _ NilTup          NilTup           = Just REFL-matchTuple m h (SnocTup t1 e1) (SnocTup t2 e2)-  | Just REFL <- matchTuple      m h t1 t2-  , Just REFL <- matchPreOpenExp m h e1 e2-  = Just REFL--matchTuple _ _ _               _                = Nothing----- Slice specifications----matchSliceRestrict-    :: SliceIndex slix s co  sh-    -> SliceIndex slix t co' sh-    -> Maybe (s :=: t)-matchSliceRestrict SliceNil SliceNil-  = Just REFL--matchSliceRestrict (SliceAll   sl1) (SliceAll   sl2)-  | Just REFL <- matchSliceRestrict sl1 sl2-  = Just REFL--matchSliceRestrict (SliceFixed sl1) (SliceFixed sl2)-  | Just REFL <- matchSliceRestrict sl1 sl2-  = Just REFL--matchSliceRestrict _ _-  = Nothing---matchSliceExtend-    :: SliceIndex slix sl co  s-    -> SliceIndex slix sl co' t-    -> Maybe (s :=: t)-matchSliceExtend SliceNil SliceNil-  = Just REFL--matchSliceExtend (SliceAll   sl1) (SliceAll   sl2)-  | Just REFL <- matchSliceExtend sl1 sl2-  = Just REFL--matchSliceExtend (SliceFixed sl1) (SliceFixed sl2)-  | Just REFL <- matchSliceExtend sl1 sl2-  = Just REFL--matchSliceExtend _ _-  = Nothing----- Primitive constants and functions----matchPrimConst :: (Elt s, Elt t) => PrimConst s -> PrimConst t -> Maybe (s :=: t)-matchPrimConst (PrimMinBound s) (PrimMinBound t) = matchBoundedType s t-matchPrimConst (PrimMaxBound s) (PrimMaxBound t) = matchBoundedType s t-matchPrimConst (PrimPi s)       (PrimPi t)       = matchFloatingType s t-matchPrimConst _                _                = Nothing----- Covariant function matching----matchPrimFun :: (Elt s, Elt t) => PrimFun (a -> s) -> PrimFun (a -> t) -> Maybe (s :=: t)-matchPrimFun (PrimAdd _)            (PrimAdd _)            = Just REFL-matchPrimFun (PrimSub _)            (PrimSub _)            = Just REFL-matchPrimFun (PrimMul _)            (PrimMul _)            = Just REFL-matchPrimFun (PrimNeg _)            (PrimNeg _)            = Just REFL-matchPrimFun (PrimAbs _)            (PrimAbs _)            = Just REFL-matchPrimFun (PrimSig _)            (PrimSig _)            = Just REFL-matchPrimFun (PrimQuot _)           (PrimQuot _)           = Just REFL-matchPrimFun (PrimRem _)            (PrimRem _)            = Just REFL-matchPrimFun (PrimIDiv _)           (PrimIDiv _)           = Just REFL-matchPrimFun (PrimMod _)            (PrimMod _)            = Just REFL-matchPrimFun (PrimBAnd _)           (PrimBAnd _)           = Just REFL-matchPrimFun (PrimBOr _)            (PrimBOr _)            = Just REFL-matchPrimFun (PrimBXor _)           (PrimBXor _)           = Just REFL-matchPrimFun (PrimBNot _)           (PrimBNot _)           = Just REFL-matchPrimFun (PrimBShiftL _)        (PrimBShiftL _)        = Just REFL-matchPrimFun (PrimBShiftR _)        (PrimBShiftR _)        = Just REFL-matchPrimFun (PrimBRotateL _)       (PrimBRotateL _)       = Just REFL-matchPrimFun (PrimBRotateR _)       (PrimBRotateR _)       = Just REFL-matchPrimFun (PrimFDiv _)           (PrimFDiv _)           = Just REFL-matchPrimFun (PrimRecip _)          (PrimRecip _)          = Just REFL-matchPrimFun (PrimSin _)            (PrimSin _)            = Just REFL-matchPrimFun (PrimCos _)            (PrimCos _)            = Just REFL-matchPrimFun (PrimTan _)            (PrimTan _)            = Just REFL-matchPrimFun (PrimAsin _)           (PrimAsin _)           = Just REFL-matchPrimFun (PrimAcos _)           (PrimAcos _)           = Just REFL-matchPrimFun (PrimAtan _)           (PrimAtan _)           = Just REFL-matchPrimFun (PrimAsinh _)          (PrimAsinh _)          = Just REFL-matchPrimFun (PrimAcosh _)          (PrimAcosh _)          = Just REFL-matchPrimFun (PrimAtanh _)          (PrimAtanh _)          = Just REFL-matchPrimFun (PrimExpFloating _)    (PrimExpFloating _)    = Just REFL-matchPrimFun (PrimSqrt _)           (PrimSqrt _)           = Just REFL-matchPrimFun (PrimLog _)            (PrimLog _)            = Just REFL-matchPrimFun (PrimFPow _)           (PrimFPow _)           = Just REFL-matchPrimFun (PrimLogBase _)        (PrimLogBase _)        = Just REFL-matchPrimFun (PrimAtan2 _)          (PrimAtan2 _)          = Just REFL-matchPrimFun (PrimTruncate _ s)     (PrimTruncate _ t)     = matchIntegralType s t-matchPrimFun (PrimRound _ s)        (PrimRound _ t)        = matchIntegralType s t-matchPrimFun (PrimFloor _ s)        (PrimFloor _ t)        = matchIntegralType s t-matchPrimFun (PrimCeiling _ s)      (PrimCeiling _ t)      = matchIntegralType s t-matchPrimFun (PrimLt _)             (PrimLt _)             = Just REFL-matchPrimFun (PrimGt _)             (PrimGt _)             = Just REFL-matchPrimFun (PrimLtEq _)           (PrimLtEq _)           = Just REFL-matchPrimFun (PrimGtEq _)           (PrimGtEq _)           = Just REFL-matchPrimFun (PrimEq _)             (PrimEq _)             = Just REFL-matchPrimFun (PrimNEq _)            (PrimNEq _)            = Just REFL-matchPrimFun (PrimMax _)            (PrimMax _)            = Just REFL-matchPrimFun (PrimMin _)            (PrimMin _)            = Just REFL-matchPrimFun (PrimFromIntegral _ s) (PrimFromIntegral _ t) = matchNumType s t-matchPrimFun PrimLAnd               PrimLAnd               = Just REFL-matchPrimFun PrimLOr                PrimLOr                = Just REFL-matchPrimFun PrimLNot               PrimLNot               = Just REFL-matchPrimFun PrimOrd                PrimOrd                = Just REFL-matchPrimFun PrimChr                PrimChr                = Just REFL-matchPrimFun PrimBoolToInt          PrimBoolToInt          = Just REFL-matchPrimFun _                      _                      = Nothing----- Contravariant function matching----matchPrimFun' :: (Elt s, Elt t) => PrimFun (s -> a) -> PrimFun (t -> a) -> Maybe (s :=: t)-matchPrimFun' (PrimAdd _)            (PrimAdd _)            = Just REFL-matchPrimFun' (PrimSub _)            (PrimSub _)            = Just REFL-matchPrimFun' (PrimMul _)            (PrimMul _)            = Just REFL-matchPrimFun' (PrimNeg _)            (PrimNeg _)            = Just REFL-matchPrimFun' (PrimAbs _)            (PrimAbs _)            = Just REFL-matchPrimFun' (PrimSig _)            (PrimSig _)            = Just REFL-matchPrimFun' (PrimQuot _)           (PrimQuot _)           = Just REFL-matchPrimFun' (PrimRem _)            (PrimRem _)            = Just REFL-matchPrimFun' (PrimIDiv _)           (PrimIDiv _)           = Just REFL-matchPrimFun' (PrimMod _)            (PrimMod _)            = Just REFL-matchPrimFun' (PrimBAnd _)           (PrimBAnd _)           = Just REFL-matchPrimFun' (PrimBOr _)            (PrimBOr _)            = Just REFL-matchPrimFun' (PrimBXor _)           (PrimBXor _)           = Just REFL-matchPrimFun' (PrimBNot _)           (PrimBNot _)           = Just REFL-matchPrimFun' (PrimBShiftL _)        (PrimBShiftL _)        = Just REFL-matchPrimFun' (PrimBShiftR _)        (PrimBShiftR _)        = Just REFL-matchPrimFun' (PrimBRotateL _)       (PrimBRotateL _)       = Just REFL-matchPrimFun' (PrimBRotateR _)       (PrimBRotateR _)       = Just REFL-matchPrimFun' (PrimFDiv _)           (PrimFDiv _)           = Just REFL-matchPrimFun' (PrimRecip _)          (PrimRecip _)          = Just REFL-matchPrimFun' (PrimSin _)            (PrimSin _)            = Just REFL-matchPrimFun' (PrimCos _)            (PrimCos _)            = Just REFL-matchPrimFun' (PrimTan _)            (PrimTan _)            = Just REFL-matchPrimFun' (PrimAsin _)           (PrimAsin _)           = Just REFL-matchPrimFun' (PrimAcos _)           (PrimAcos _)           = Just REFL-matchPrimFun' (PrimAtan _)           (PrimAtan _)           = Just REFL-matchPrimFun' (PrimAsinh _)          (PrimAsinh _)          = Just REFL-matchPrimFun' (PrimAcosh _)          (PrimAcosh _)          = Just REFL-matchPrimFun' (PrimAtanh _)          (PrimAtanh _)          = Just REFL-matchPrimFun' (PrimExpFloating _)    (PrimExpFloating _)    = Just REFL-matchPrimFun' (PrimSqrt _)           (PrimSqrt _)           = Just REFL-matchPrimFun' (PrimLog _)            (PrimLog _)            = Just REFL-matchPrimFun' (PrimFPow _)           (PrimFPow _)           = Just REFL-matchPrimFun' (PrimLogBase _)        (PrimLogBase _)        = Just REFL-matchPrimFun' (PrimAtan2 _)          (PrimAtan2 _)          = Just REFL-matchPrimFun' (PrimTruncate s _)     (PrimTruncate t _)     = matchFloatingType s t-matchPrimFun' (PrimRound s _)        (PrimRound t _)        = matchFloatingType s t-matchPrimFun' (PrimFloor s _)        (PrimFloor t _)        = matchFloatingType s t-matchPrimFun' (PrimCeiling s _)      (PrimCeiling t _)      = matchFloatingType s t-matchPrimFun' (PrimMax _)            (PrimMax _)            = Just REFL-matchPrimFun' (PrimMin _)            (PrimMin _)            = Just REFL-matchPrimFun' (PrimFromIntegral s _) (PrimFromIntegral t _) = matchIntegralType s t-matchPrimFun' PrimLAnd               PrimLAnd               = Just REFL-matchPrimFun' PrimLOr                PrimLOr                = Just REFL-matchPrimFun' PrimLNot               PrimLNot               = Just REFL-matchPrimFun' PrimOrd                PrimOrd                = Just REFL-matchPrimFun' PrimChr                PrimChr                = Just REFL-matchPrimFun' PrimBoolToInt          PrimBoolToInt          = Just REFL-matchPrimFun' (PrimLt s) (PrimLt t)-  | Just REFL <- matchScalarType s t-  = Just REFL--matchPrimFun' (PrimGt s) (PrimGt t)-  | Just REFL <- matchScalarType s t-  = Just REFL--matchPrimFun' (PrimLtEq s) (PrimLtEq t)-  | Just REFL <- matchScalarType s t-  = Just REFL--matchPrimFun' (PrimGtEq s) (PrimGtEq t)-  | Just REFL <- matchScalarType s t-  = Just REFL--matchPrimFun' (PrimEq s) (PrimEq t)-  | Just REFL <- matchScalarType s t-  = Just REFL--matchPrimFun' (PrimNEq s) (PrimNEq t)-  | Just REFL <- matchScalarType s t-  = Just REFL--matchPrimFun' _ _-  = Nothing----- Match reified types----matchTupleType :: TupleType s -> TupleType t -> Maybe (s :=: t)-matchTupleType UnitTuple         UnitTuple         = Just REFL-matchTupleType (SingleTuple s)   (SingleTuple t)   = matchScalarType s t-matchTupleType (PairTuple s1 s2) (PairTuple t1 t2)-  | Just REFL <- matchTupleType s1 t1-  , Just REFL <- matchTupleType s2 t2-  = Just REFL--matchTupleType _ _-  = Nothing----- Match reified type dictionaries----matchScalarType :: ScalarType s -> ScalarType t -> Maybe (s :=: t)-matchScalarType (NumScalarType s)    (NumScalarType t)    = matchNumType s t-matchScalarType (NonNumScalarType s) (NonNumScalarType t) = matchNonNumType s t-matchScalarType _                    _                    = Nothing--matchNumType :: NumType s -> NumType t -> Maybe (s :=: t)-matchNumType (IntegralNumType s) (IntegralNumType t) = matchIntegralType s t-matchNumType (FloatingNumType s) (FloatingNumType t) = matchFloatingType s t-matchNumType _                   _                   = Nothing--matchBoundedType :: BoundedType s -> BoundedType t -> Maybe (s :=: t)-matchBoundedType (IntegralBoundedType s) (IntegralBoundedType t) = matchIntegralType s t-matchBoundedType (NonNumBoundedType s)   (NonNumBoundedType t)   = matchNonNumType s t-matchBoundedType _                       _                       = Nothing--matchIntegralType :: IntegralType s -> IntegralType t -> Maybe (s :=: t)-matchIntegralType (TypeInt _)     (TypeInt _)     = Just REFL-matchIntegralType (TypeInt8 _)    (TypeInt8 _)    = Just REFL-matchIntegralType (TypeInt16 _)   (TypeInt16 _)   = Just REFL-matchIntegralType (TypeInt32 _)   (TypeInt32 _)   = Just REFL-matchIntegralType (TypeInt64 _)   (TypeInt64 _)   = Just REFL-matchIntegralType (TypeWord _)    (TypeWord _)    = Just REFL-matchIntegralType (TypeWord8 _)   (TypeWord8 _)   = Just REFL-matchIntegralType (TypeWord16 _)  (TypeWord16 _)  = Just REFL-matchIntegralType (TypeWord32 _)  (TypeWord32 _)  = Just REFL-matchIntegralType (TypeWord64 _)  (TypeWord64 _)  = Just REFL-matchIntegralType (TypeCShort _)  (TypeCShort _)  = Just REFL-matchIntegralType (TypeCUShort _) (TypeCUShort _) = Just REFL-matchIntegralType (TypeCInt _)    (TypeCInt _)    = Just REFL-matchIntegralType (TypeCUInt _)   (TypeCUInt _)   = Just REFL-matchIntegralType (TypeCLong _)   (TypeCLong _)   = Just REFL-matchIntegralType (TypeCULong _)  (TypeCULong _)  = Just REFL-matchIntegralType (TypeCLLong _)  (TypeCLLong _)  = Just REFL-matchIntegralType (TypeCULLong _) (TypeCULLong _) = Just REFL-matchIntegralType _               _               = Nothing--matchFloatingType :: FloatingType s -> FloatingType t -> Maybe (s :=: t)-matchFloatingType (TypeFloat _)   (TypeFloat _)   = Just REFL-matchFloatingType (TypeDouble _)  (TypeDouble _)  = Just REFL-matchFloatingType (TypeCFloat _)  (TypeCFloat _)  = Just REFL-matchFloatingType (TypeCDouble _) (TypeCDouble _) = Just REFL-matchFloatingType _               _               = Nothing--matchNonNumType :: NonNumType s -> NonNumType t -> Maybe (s :=: t)-matchNonNumType (TypeBool _)   (TypeBool _)   = Just REFL-matchNonNumType (TypeChar _)   (TypeChar _)   = Just REFL-matchNonNumType (TypeCChar _)  (TypeCChar _)  = Just REFL-matchNonNumType (TypeCSChar _) (TypeCSChar _) = Just REFL-matchNonNumType (TypeCUChar _) (TypeCUChar _) = Just REFL-matchNonNumType _              _              = Nothing----- Discriminate binary functions that commute, and if so return the operands in--- a stable ordering such that matching recognises expressions modulo--- commutativity.----commutes-    :: forall acc env aenv a r.-       HashAcc acc-    -> PrimFun (a -> r)-    -> PreOpenExp acc env aenv a-    -> Maybe (PreOpenExp acc env aenv a)-commutes h f x = case f of-  PrimAdd _     -> Just (swizzle x)-  PrimMul _     -> Just (swizzle x)-  PrimBAnd _    -> Just (swizzle x)-  PrimBOr _     -> Just (swizzle x)-  PrimBXor _    -> Just (swizzle x)-  PrimEq _      -> Just (swizzle x)-  PrimNEq _     -> Just (swizzle x)-  PrimMax _     -> Just (swizzle x)-  PrimMin _     -> Just (swizzle x)-  PrimLAnd      -> Just (swizzle x)-  PrimLOr       -> Just (swizzle x)-  _             -> Nothing-  where-    swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a')-    swizzle exp-      | Tuple (NilTup `SnocTup` a `SnocTup` b)  <- exp-      , hashPreOpenExp h a > hashPreOpenExp h b = Tuple (NilTup `SnocTup` b `SnocTup` a)-      ---      | otherwise                               = exp----- Hashing--- =======--hashIdx :: Idx env t -> Int-hashIdx = hash . idxToInt--hashTupleIdx :: TupleIdx tup e -> Int-hashTupleIdx = hash . tupleIdxToInt----- Array computations--- --------------------type HashAcc acc = forall aenv a. acc aenv a -> Int---hashOpenAcc :: OpenAcc aenv arrs -> Int-hashOpenAcc (OpenAcc pacc) = hashPreOpenAcc hashOpenAcc pacc--hashPreOpenAcc :: forall acc aenv arrs. HashAcc acc -> PreOpenAcc acc aenv arrs -> Int-hashPreOpenAcc hashAcc pacc =-  let-    hashA :: Int -> acc aenv' a -> Int-    hashA salt = hashWithSalt salt . hashAcc--    hashE :: Int -> PreOpenExp acc env' aenv' e -> Int-    hashE salt = hashWithSalt salt . hashPreOpenExp hashAcc--    hashF :: Int -> PreOpenFun acc env' aenv' f -> Int-    hashF salt = hashWithSalt salt . hashPreOpenFun hashAcc--  in case pacc of-    Alet bnd body               -> hash "Alet"          `hashA` bnd `hashA` body-    Avar v                      -> hash "Avar"          `hashWithSalt` hashIdx v-    Atuple t                    -> hash "Atuple"        `hashWithSalt` hashAtuple hashAcc t-    Aprj ix a                   -> hash "Aprj"          `hashWithSalt` hashTupleIdx ix    `hashA` a-    Apply f a                   -> hash "Apply"         `hashWithSalt` hashAfun hashAcc f `hashA` a-    Aforeign _ f a              -> hash "Aforeign"      `hashWithSalt` hashAfun hashAcc f `hashA` a-    Use a                       -> hash "Use"           `hashWithSalt` hashArrays (arrays (undefined::arrs)) a-    Awhile p f a                -> hash "Awhile"        `hashWithSalt` hashAfun hashAcc f `hashWithSalt` hashAfun hashAcc p `hashA` a-    Unit e                      -> hash "Unit"          `hashE` e-    Generate e f                -> hash "Generate"      `hashE` e  `hashF` f-    Acond e a1 a2               -> hash "Acond"         `hashE` e  `hashA` a1 `hashA` a2-    Reshape sh a                -> hash "Reshape"       `hashE` sh `hashA` a-    Transform sh f1 f2 a        -> hash "Transform"     `hashE` sh `hashF` f1 `hashF` f2 `hashA` a-    Replicate spec ix a         -> hash "Replicate"     `hashE` ix `hashA` a  `hashWithSalt` show spec-    Slice spec a ix             -> hash "Slice"         `hashE` ix `hashA` a  `hashWithSalt` show spec-    Map f a                     -> hash "Map"           `hashF` f  `hashA` a-    ZipWith f a1 a2             -> hash "ZipWith"       `hashF` f  `hashA` a1 `hashA` a2-    Fold f e a                  -> hash "Fold"          `hashF` f  `hashE` e  `hashA` a-    Fold1 f a                   -> hash "Fold1"         `hashF` f  `hashA` a-    FoldSeg f e a s             -> hash "FoldSeg"       `hashF` f  `hashE` e  `hashA` a  `hashA` s-    Fold1Seg f a s              -> hash "Fold1Seg"      `hashF` f  `hashA` a  `hashA` s-    Scanl f e a                 -> hash "Scanl"         `hashF` f  `hashE` e  `hashA` a-    Scanl' f e a                -> hash "Scanl'"        `hashF` f  `hashE` e  `hashA` a-    Scanl1 f a                  -> hash "Scanl1"        `hashF` f  `hashA` a-    Scanr f e a                 -> hash "Scanr"         `hashF` f  `hashE` e  `hashA` a-    Scanr' f e a                -> hash "Scanr'"        `hashF` f  `hashE` e  `hashA` a-    Scanr1 f a                  -> hash "Scanr1"        `hashF` f  `hashA` a-    Backpermute sh f a          -> hash "Backpermute"   `hashF` f  `hashE` sh `hashA` a-    Permute f1 a1 f2 a2         -> hash "Permute"       `hashF` f1 `hashA` a1 `hashF` f2 `hashA` a2-    Stencil f b a               -> hash "Stencil"       `hashF` f  `hashA` a             `hashWithSalt` hashBoundary a  b-    Stencil2 f b1 a1 b2 a2      -> hash "Stencil2"      `hashF` f  `hashA` a1 `hashA` a2 `hashWithSalt` hashBoundary a1 b1 `hashWithSalt` hashBoundary a2 b2---hashArrays :: ArraysR a -> a -> Int-hashArrays ArraysRunit         ()       = hash ()-hashArrays (ArraysRpair r1 r2) (a1, a2) = hash ( hashArrays r1 a1, hashArrays r2 a2)-hashArrays ArraysRarray        ad       = unsafePerformIO $! hashStableName `fmap` makeStableName ad--hashAtuple :: HashAcc acc -> Tuple.Atuple (acc aenv) a -> Int-hashAtuple _ NilAtup            = hash "NilAtup"-hashAtuple h (SnocAtup t a)     = hash "SnocAtup"       `hashWithSalt` hashAtuple h t `hashWithSalt` h a--hashAfun :: HashAcc acc -> PreOpenAfun acc aenv f -> Int-hashAfun h (Abody b)            = hash "Abody"          `hashWithSalt` h b-hashAfun h (Alam f)             = hash "Alam"           `hashWithSalt` hashAfun h f--hashBoundary :: forall acc aenv sh e. Elt e => acc aenv (Array sh e) -> Boundary (EltRepr e) -> Int-hashBoundary _ Wrap             = hash "Wrap"-hashBoundary _ Clamp            = hash "Clamp"-hashBoundary _ Mirror           = hash "Mirror"-hashBoundary _ (Constant c)     = hash "Constant"       `hashWithSalt` show (toElt c :: e)----- Scalar expressions--- --------------------hashOpenExp :: OpenExp env aenv exp -> Int-hashOpenExp = hashPreOpenExp hashOpenAcc--hashPreOpenExp :: forall acc env aenv exp. HashAcc acc -> PreOpenExp acc env aenv exp -> Int-hashPreOpenExp hashAcc exp =-  let-    hashA :: Int -> acc aenv' a -> Int-    hashA salt = hashWithSalt salt . hashAcc--    hashE :: Int -> PreOpenExp acc env' aenv' e -> Int-    hashE salt = hashWithSalt salt . hashPreOpenExp hashAcc--  in case exp of-    Let bnd body                -> hash "Let"           `hashE` bnd `hashE` body-    Var ix                      -> hash "Var"           `hashWithSalt` hashIdx ix-    Const c                     -> hash "Const"         `hashWithSalt` show (toElt c :: exp)-    Tuple t                     -> hash "Tuple"         `hashWithSalt` hashTuple hashAcc t-    Prj i e                     -> hash "Prj"           `hashWithSalt` hashTupleIdx i `hashE` e-    IndexAny                    -> hash "IndexAny"-    IndexNil                    -> hash "IndexNil"-    IndexCons sl a              -> hash "IndexCons"     `hashE` sl `hashE` a-    IndexHead sl                -> hash "IndexHead"     `hashE` sl-    IndexTail sl                -> hash "IndexTail"     `hashE` sl-    IndexSlice spec ix sh       -> hash "IndexSlice"    `hashE` ix `hashE` sh `hashWithSalt` show spec-    IndexFull  spec ix sl       -> hash "IndexFull"     `hashE` ix `hashE` sl `hashWithSalt` show spec-    ToIndex sh i                -> hash "ToIndex"       `hashE` sh `hashE` i-    FromIndex sh i              -> hash "FromIndex"     `hashE` sh `hashE` i-    Cond c t e                  -> hash "Cond"          `hashE` c  `hashE` t  `hashE` e-    While p f x                 -> hash "While"         `hashWithSalt` hashPreOpenFun hashAcc p  `hashWithSalt` hashPreOpenFun hashAcc f  `hashE` x-    PrimApp f x                 -> hash "PrimApp"       `hashWithSalt` hashPrimFun f `hashE` fromMaybe x (commutes hashAcc f x)-    PrimConst c                 -> hash "PrimConst"     `hashWithSalt` hashPrimConst c-    Index a ix                  -> hash "Index"         `hashA` a  `hashE` ix-    LinearIndex a ix            -> hash "LinearIndex"   `hashA` a  `hashE` ix-    Shape a                     -> hash "Shape"         `hashA` a-    ShapeSize sh                -> hash "ShapeSize"     `hashE` sh-    Intersect sa sb             -> hash "Intersect"     `hashE` sa `hashE` sb-    Foreign _ f e               -> hash "Foreign"       `hashWithSalt` hashPreOpenFun hashAcc f `hashE` e---hashPreOpenFun :: HashAcc acc -> PreOpenFun acc env aenv f -> Int-hashPreOpenFun h (Body e)       = hash "Body"           `hashWithSalt` hashPreOpenExp h e-hashPreOpenFun h (Lam f)        = hash "Lam"            `hashWithSalt` hashPreOpenFun h f--hashTuple :: HashAcc acc -> Tuple.Tuple (PreOpenExp acc env aenv) e -> Int-hashTuple _ NilTup              = hash "NilTup"-hashTuple h (SnocTup t e)       = hash "SnocTup"        `hashWithSalt` hashTuple h t `hashWithSalt` hashPreOpenExp h e---hashPrimConst :: PrimConst c -> Int-hashPrimConst (PrimMinBound _)  = hash "PrimMinBound"-hashPrimConst (PrimMaxBound _)  = hash "PrimMaxBound"-hashPrimConst (PrimPi _)        = hash "PrimPi"--hashPrimFun :: PrimFun f -> Int-hashPrimFun (PrimAdd _)                 = hash "PrimAdd"-hashPrimFun (PrimSub _)                 = hash "PrimSub"-hashPrimFun (PrimMul _)                 = hash "PrimMul"-hashPrimFun (PrimNeg _)                 = hash "PrimNeg"-hashPrimFun (PrimAbs _)                 = hash "PrimAbs"-hashPrimFun (PrimSig _)                 = hash "PrimSig"-hashPrimFun (PrimQuot _)                = hash "PrimQuot"-hashPrimFun (PrimRem _)                 = hash "PrimRem"-hashPrimFun (PrimIDiv _)                = hash "PrimIDiv"-hashPrimFun (PrimMod _)                 = hash "PrimMod"-hashPrimFun (PrimBAnd _)                = hash "PrimBAnd"-hashPrimFun (PrimBOr _)                 = hash "PrimBOr"-hashPrimFun (PrimBXor _)                = hash "PrimBXor"-hashPrimFun (PrimBNot _)                = hash "PrimBNot"-hashPrimFun (PrimBShiftL _)             = hash "PrimBShiftL"-hashPrimFun (PrimBShiftR _)             = hash "PrimBShiftR"-hashPrimFun (PrimBRotateL _)            = hash "PrimBRotateL"-hashPrimFun (PrimBRotateR _)            = hash "PrimBRotateR"-hashPrimFun (PrimFDiv _)                = hash "PrimFDiv"-hashPrimFun (PrimRecip _)               = hash "PrimRecip"-hashPrimFun (PrimSin _)                 = hash "PrimSin"-hashPrimFun (PrimCos _)                 = hash "PrimCos"-hashPrimFun (PrimTan _)                 = hash "PrimTan"-hashPrimFun (PrimAsin _)                = hash "PrimAsin"-hashPrimFun (PrimAcos _)                = hash "PrimAcos"-hashPrimFun (PrimAtan _)                = hash "PrimAtan"-hashPrimFun (PrimAsinh _)               = hash "PrimAsinh"-hashPrimFun (PrimAcosh _)               = hash "PrimAcosh"-hashPrimFun (PrimAtanh _)               = hash "PrimAtanh"-hashPrimFun (PrimExpFloating _)         = hash "PrimExpFloating"-hashPrimFun (PrimSqrt _)                = hash "PrimSqrt"-hashPrimFun (PrimLog _)                 = hash "PrimLog"-hashPrimFun (PrimFPow _)                = hash "PrimFPow"-hashPrimFun (PrimLogBase _)             = hash "PrimLogBase"-hashPrimFun (PrimAtan2 _)               = hash "PrimAtan2"-hashPrimFun (PrimTruncate _ _)          = hash "PrimTruncate"-hashPrimFun (PrimRound _ _)             = hash "PrimRound"-hashPrimFun (PrimFloor _ _)             = hash "PrimFloor"-hashPrimFun (PrimCeiling _ _)           = hash "PrimCeiling"-hashPrimFun (PrimLt _)                  = hash "PrimLt"-hashPrimFun (PrimGt _)                  = hash "PrimGt"-hashPrimFun (PrimLtEq _)                = hash "PrimLtEq"-hashPrimFun (PrimGtEq _)                = hash "PrimGtEq"-hashPrimFun (PrimEq _)                  = hash "PrimEq"-hashPrimFun (PrimNEq _)                 = hash "PrimNEq"-hashPrimFun (PrimMax _)                 = hash "PrimMax"-hashPrimFun (PrimMin _)                 = hash "PrimMin"-hashPrimFun (PrimFromIntegral _ _)      = hash "PrimFromIntegral"-hashPrimFun PrimLAnd                    = hash "PrimLAnd"-hashPrimFun PrimLOr                     = hash "PrimLOr"-hashPrimFun PrimLNot                    = hash "PrimLNot"-hashPrimFun PrimOrd                     = hash "PrimOrd"-hashPrimFun PrimChr                     = hash "PrimChr"-hashPrimFun PrimBoolToInt               = hash "PrimBoolToInt"+-- Copyright   : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Analysis.Match (++  -- matching expressions+  MatchAcc,+  (:~:)(..),+  matchOpenAcc,  matchPreOpenAcc,+  matchOpenAfun, matchPreOpenAfun,+  matchOpenExp,  matchPreOpenExp,+  matchOpenFun,  matchPreOpenFun,+  matchPrimFun,  matchPrimFun',++  -- auxiliary+  matchIdx, matchTupleType,+  matchIntegralType, matchFloatingType, matchNumType, matchScalarType,++  -- hashing expressions+  HashAcc,+  hashPreOpenAcc, hashOpenAcc,+  hashPreOpenExp, hashOpenExp,+  hashPreOpenFun,++) where++-- standard library+import Prelude                                          hiding ( exp )+import Data.Maybe+import Data.Typeable+import Data.Hashable+import System.Mem.StableName+import System.IO.Unsafe                                 ( unsafePerformIO )++-- friends+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Array.Representation       ( SliceIndex(..) )+import Data.Array.Accelerate.Product+++-- The type of matching array computations+--+type MatchAcc acc = forall aenv s t. acc aenv s -> acc aenv t -> Maybe (s :~: t)+++-- Compute the congruence of two array computations. The nodes are congruent if+-- they have the same operator and their operands are congruent.+--+{-# INLINEABLE matchOpenAcc #-}+matchOpenAcc+    :: OpenAcc aenv s+    -> OpenAcc aenv t+    -> Maybe (s :~: t)+matchOpenAcc (OpenAcc acc1) (OpenAcc acc2) =+  matchPreOpenAcc matchOpenAcc hashOpenAcc acc1 acc2+++matchPreOpenAcc+    :: forall acc aenv s t.+       MatchAcc acc+    -> HashAcc  acc+    -> PreOpenAcc acc aenv s+    -> PreOpenAcc acc aenv t+    -> Maybe (s :~: t)+matchPreOpenAcc matchAcc hashAcc = match+  where+    matchFun :: PreOpenFun acc env' aenv' u -> PreOpenFun acc env' aenv' v -> Maybe (u :~: v)+    matchFun = matchPreOpenFun matchAcc hashAcc++    matchExp :: PreOpenExp acc env' aenv' u -> PreOpenExp acc env' aenv' v -> Maybe (u :~: v)+    matchExp = matchPreOpenExp matchAcc hashAcc++    match :: PreOpenAcc acc aenv s -> PreOpenAcc acc aenv t -> Maybe (s :~: t)+    match (Alet x1 a1) (Alet x2 a2)+      | Just Refl <- matchAcc x1 x2+      , Just Refl <- matchAcc a1 a2+      = Just Refl++    match (Avar v1) (Avar v2)+      = matchIdx v1 v2++    match (Atuple t1) (Atuple t2)+      | Just Refl <- matchAtuple matchAcc t1 t2+      = gcast Refl  -- surface/representation type++    match (Aprj ix1 t1) (Aprj ix2 t2)+      | Just Refl <- matchAcc t1 t2+      , Just Refl <- matchTupleIdx ix1 ix2+      = Just Refl++    match (Apply f1 a1) (Apply f2 a2)+      | Just Refl <- matchPreOpenAfun matchAcc f1 f2+      , Just Refl <- matchAcc                  a1 a2+      = Just Refl++    match (Aforeign ff1 _ a1) (Aforeign ff2 _ a2)+      | Just Refl <- matchAcc a1 a2+      , unsafePerformIO $ do+          sn1 <- makeStableName ff1+          sn2 <- makeStableName ff2+          return $! hashStableName sn1 == hashStableName sn2+      = gcast Refl++    match (Acond p1 t1 e1) (Acond p2 t2 e2)+      | Just Refl <- matchExp p1 p2+      , Just Refl <- matchAcc t1 t2+      , Just Refl <- matchAcc e1 e2+      = Just Refl++    match (Awhile p1 f1 a1) (Awhile p2 f2 a2)+      | Just Refl <- matchAcc a1 a2+      , Just Refl <- matchPreOpenAfun matchAcc p1 p2+      , Just Refl <- matchPreOpenAfun matchAcc f1 f2+      = Just Refl++    match (Use a1) (Use a2)+      | Just Refl <- matchArrays (arrays (undefined::s)) (arrays (undefined::t)) a1 a2+      = gcast Refl++    match (Unit e1) (Unit e2)+      | Just Refl <- matchExp e1 e2+      = Just Refl++    match (Reshape sh1 a1) (Reshape sh2 a2)+      | Just Refl <- matchExp sh1 sh2+      , Just Refl <- matchAcc a1  a2+      = Just Refl++    match (Generate sh1 f1) (Generate sh2 f2)+      | Just Refl <- matchExp sh1 sh2+      , Just Refl <- matchFun f1  f2+      = Just Refl++    match (Transform sh1 ix1 f1 a1) (Transform sh2 ix2 f2 a2)+      | Just Refl <- matchExp sh1 sh2+      , Just Refl <- matchFun ix1 ix2+      , Just Refl <- matchFun f1  f2+      , Just Refl <- matchAcc a1  a2+      = Just Refl++    match (Replicate _ ix1 a1) (Replicate _ ix2 a2)+      | Just Refl <- matchExp ix1 ix2+      , Just Refl <- matchAcc a1  a2+      = gcast Refl  -- slice specification ??++    match (Slice _ a1 ix1) (Slice _ a2 ix2)+      | Just Refl <- matchAcc a1  a2+      , Just Refl <- matchExp ix1 ix2+      = gcast Refl  -- slice specification ??++    match (Map f1 a1) (Map f2 a2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchAcc a1 a2+      = Just Refl++    match (ZipWith f1 a1 b1) (ZipWith f2 a2 b2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchAcc a1 a2+      , Just Refl <- matchAcc b1 b2+      = Just Refl++    match (Fold f1 z1 a1) (Fold f2 z2 a2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchExp z1 z2+      , Just Refl <- matchAcc a1 a2+      = Just Refl++    match (Fold1 f1 a1) (Fold1 f2 a2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchAcc a1 a2+      = Just Refl++    match (FoldSeg f1 z1 a1 s1) (FoldSeg f2 z2 a2 s2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchExp z1 z2+      , Just Refl <- matchAcc a1 a2+      , Just Refl <- matchAcc s1 s2+      = Just Refl++    match (Fold1Seg f1 a1 s1) (Fold1Seg f2 a2 s2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchAcc a1 a2+      , Just Refl <- matchAcc s1 s2+      = Just Refl++    match (Scanl f1 z1 a1) (Scanl f2 z2 a2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchExp z1 z2+      , Just Refl <- matchAcc a1 a2+      = Just Refl++    match (Scanl' f1 z1 a1) (Scanl' f2 z2 a2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchExp z1 z2+      , Just Refl <- matchAcc a1 a2+      = Just Refl++    match (Scanl1 f1 a1) (Scanl1 f2 a2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchAcc a1 a2+      = Just Refl++    match (Scanr f1 z1 a1) (Scanr f2 z2 a2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchExp z1 z2+      , Just Refl <- matchAcc a1 a2+      = Just Refl++    match (Scanr' f1 z1 a1) (Scanr' f2 z2 a2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchExp z1 z2+      , Just Refl <- matchAcc a1 a2+      = Just Refl++    match (Scanr1 f1 a1) (Scanr1 f2 a2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchAcc a1 a2+      = Just Refl++    match (Permute f1 d1 p1 a1) (Permute f2 d2 p2 a2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchAcc d1 d2+      , Just Refl <- matchFun p1 p2+      , Just Refl <- matchAcc a1 a2+      = Just Refl++    match (Backpermute sh1 ix1 a1) (Backpermute sh2 ix2 a2)+      | Just Refl <- matchExp sh1 sh2+      , Just Refl <- matchFun ix1 ix2+      , Just Refl <- matchAcc a1  a2+      = Just Refl++    match (Stencil f1 b1 (a1 :: acc aenv (Array sh1 e1)))+          (Stencil f2 b2 (a2 :: acc aenv (Array sh2 e2)))+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchAcc a1 a2+      , matchBoundary (eltType (undefined::e1)) b1 b2+      = Just Refl++    match (Stencil2 f1 b1  (a1  :: acc aenv (Array sh1  e1 )) b2  (a2 :: acc aenv (Array sh2  e2 )))+          (Stencil2 f2 b1' (a1' :: acc aenv (Array sh1' e1')) b2' (a2':: acc aenv (Array sh2' e2')))+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchAcc a1 a1'+      , Just Refl <- matchAcc a2 a2'+      , matchBoundary (eltType (undefined::e1)) b1 b1'+      , matchBoundary (eltType (undefined::e2)) b2 b2'+      = Just Refl++    -- match (Collect s1) (Collect s2)+    --   = matchSeq matchAcc hashAcc s1 s2++    match _ _+      = Nothing+++-- Array tuples+--+matchAtuple+    :: MatchAcc acc+    -> Atuple (acc aenv) s+    -> Atuple (acc aenv) t+    -> Maybe (s :~: t)+matchAtuple matchAcc (SnocAtup t1 a1) (SnocAtup t2 a2)+  | Just Refl <- matchAtuple matchAcc t1 t2+  , Just Refl <- matchAcc             a1 a2+  = Just Refl++matchAtuple _ NilAtup NilAtup = Just Refl+matchAtuple _ _       _       = Nothing+++-- Array functions+--+matchOpenAfun+    :: OpenAfun aenv s+    -> OpenAfun aenv t+    -> Maybe (s :~: t)+matchOpenAfun = matchPreOpenAfun matchOpenAcc++matchPreOpenAfun+    :: MatchAcc acc+    -> PreOpenAfun acc aenv s+    -> PreOpenAfun acc aenv t+    -> Maybe (s :~: t)+matchPreOpenAfun m (Alam s) (Alam t)+  | Just Refl <- matchEnvTop        s t+  , Just Refl <- matchPreOpenAfun m s t+  = Just Refl+  where+    matchEnvTop :: (Arrays s, Arrays t)+                => PreOpenAfun acc (aenv, s) f -> PreOpenAfun acc (aenv, t) g -> Maybe (s :~: t)+    matchEnvTop _ _ = gcast Refl  -- ???++matchPreOpenAfun m (Abody s) (Abody t) = m s t+matchPreOpenAfun _ _         _         = Nothing+++-- Match stencil boundaries+--+matchBoundary :: TupleType e -> Boundary e -> Boundary e -> Bool+matchBoundary ty (Constant s) (Constant t) = matchConst ty s t+matchBoundary _  Wrap         Wrap         = True+matchBoundary _  Clamp        Clamp        = True+matchBoundary _  Mirror       Mirror       = True+matchBoundary _  _            _            = False+++{--+-- Match sequences+--+matchSeq+    :: forall acc aenv senv s t.+       MatchAcc acc+    -> HashAcc acc+    -> PreOpenSeq acc aenv senv s+    -> PreOpenSeq acc aenv senv t+    -> Maybe (s :~: t)+matchSeq m h = match+  where+    matchFun :: PreOpenFun acc env' aenv' u -> PreOpenFun acc env' aenv' v -> Maybe (u :~: v)+    matchFun = matchPreOpenFun m h++    matchExp :: PreOpenExp acc env' aenv' u -> PreOpenExp acc env' aenv' v -> Maybe (u :~: v)+    matchExp = matchPreOpenExp m h++    match :: PreOpenSeq acc aenv senv' u -> PreOpenSeq acc aenv senv' v -> Maybe (u :~: v)+    match (Producer p1 s1)   (Producer p2 s2)+      | Just Refl <- matchP p1 p2+      , Just Refl <- match s1 s2+      = Just Refl+    match (Consumer c1)   (Consumer c2)+      | Just Refl <- matchC c1 c2+      = Just Refl+    match (Reify ix1) (Reify ix2)+      | Just Refl <- matchIdx ix1 ix2+      = Just Refl+    match _ _+      = Nothing++    matchP :: Producer acc aenv senv' u -> Producer acc aenv senv' v -> Maybe (u :~: v)+    matchP (StreamIn arrs1) (StreamIn arrs2)+      | unsafePerformIO $ do+          sn1 <- makeStableName arrs1+          sn2 <- makeStableName arrs2+          return $! hashStableName sn1 == hashStableName sn2+      = gcast Refl+    matchP (ToSeq _ (_::proxy1 slix1) a1) (ToSeq _ (_::proxy2 slix2) a2)+      | Just Refl <- gcast Refl :: Maybe (slix1 :~: slix2) -- Divisions are singleton.+      , Just Refl <- m a1 a2+      = gcast Refl+    matchP (MapSeq f1 x1) (MapSeq f2 x2)+      | Just Refl <- matchPreOpenAfun m f1 f2+      , Just Refl <- matchIdx x1 x2+      = Just Refl+    matchP (ZipWithSeq f1 x1 y1) (ZipWithSeq f2 x2 y2)+      | Just Refl <- matchPreOpenAfun m f1 f2+      , Just Refl <- matchIdx x1 x2+      , Just Refl <- matchIdx y1 y2+      = Just Refl+    matchP (ScanSeq f1 e1 x1) (ScanSeq f2 e2 x2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchIdx x1 x2+      , Just Refl <- matchExp e1 e2+      = Just Refl+    matchP _ _+      = Nothing++    matchC :: Consumer acc aenv senv' u -> Consumer acc aenv senv' v -> Maybe (u :~: v)+    matchC (FoldSeq f1 e1 x1) (FoldSeq f2 e2 x2)+      | Just Refl <- matchIdx x1 x2+      , Just Refl <- matchFun f1 f2+      , Just Refl <- matchExp e1 e2+      = Just Refl+    matchC (FoldSeqFlatten f1 acc1 x1) (FoldSeqFlatten f2 acc2 x2)+      | Just Refl <- matchIdx x1 x2+      , Just Refl <- matchPreOpenAfun m f1 f2+      , Just Refl <- m acc1 acc2+      = Just Refl+    matchC (Stuple s1) (Stuple s2)+      | Just Refl <- matchAtuple matchC s1 s2+      = gcast Refl+    matchC _ _+      = Nothing+--}++-- Match arrays+--+-- As a convenience, we are just comparing the stable names, but we could also+-- walk the structure comparing the underlying ptrsOfArrayData.+--+matchArrays :: ArraysR s -> ArraysR t -> s -> t -> Maybe (s :~: t)+matchArrays ArraysRunit ArraysRunit () ()+  = Just Refl++matchArrays (ArraysRpair a1 b1) (ArraysRpair a2 b2) (arr1,brr1) (arr2,brr2)+  | Just Refl <- matchArrays a1 a2 arr1 arr2+  , Just Refl <- matchArrays b1 b2 brr1 brr2+  = Just Refl++matchArrays ArraysRarray ArraysRarray (Array _ ad1) (Array _ ad2)+  | unsafePerformIO $ do+      sn1 <- makeStableName ad1+      sn2 <- makeStableName ad2+      return $! hashStableName sn1 == hashStableName sn2+  = gcast Refl++matchArrays _ _ _ _+  = Nothing+++-- Compute the congruence of two scalar expressions. Two nodes are congruent if+-- either:+--+--  1. The nodes label constants and the contents are equal+--  2. They have the same operator and their operands are congruent+--+-- The below attempts to use real typed equality, but occasionally still needs+-- to use a cast, particularly when we can only match the representation types.+--+matchOpenExp+    :: OpenExp env aenv s+    -> OpenExp env aenv t+    -> Maybe (s :~: t)+matchOpenExp = matchPreOpenExp matchOpenAcc hashOpenAcc++matchPreOpenExp+    :: forall acc env aenv s t.+       MatchAcc acc+    -> HashAcc  acc+    -> PreOpenExp acc env aenv s+    -> PreOpenExp acc env aenv t+    -> Maybe (s :~: t)+matchPreOpenExp matchAcc hashAcc = match+  where+    match :: forall env' aenv' s' t'.+             PreOpenExp acc env' aenv' s'+          -> PreOpenExp acc env' aenv' t'+          -> Maybe (s' :~: t')+    match (Let x1 e1) (Let x2 e2)+      | Just Refl <- match x1 x2+      , Just Refl <- match e1 e2+      = Just Refl++    match (Var v1) (Var v2)+      = matchIdx v1 v2++    match (Foreign ff1 _ e1) (Foreign ff2 _ e2)+      | Just Refl <- match e1 e2+      , unsafePerformIO $ do+          sn1 <- makeStableName ff1+          sn2 <- makeStableName ff2+          return $! hashStableName sn1 == hashStableName sn2+      = gcast Refl++    match (Const c1) (Const c2)+      | Just Refl <- matchTupleType (eltType (undefined::s')) (eltType (undefined::t'))+      , matchConst (eltType (undefined::s')) c1 c2+      = gcast Refl  -- surface/representation type++    match (Tuple t1) (Tuple t2)+      | Just Refl <- matchTuple matchAcc hashAcc t1 t2+      = gcast Refl  -- surface/representation type++    match (Prj ix1 t1) (Prj ix2 t2)+      | Just Refl <- match         t1  t2+      , Just Refl <- matchTupleIdx ix1 ix2+      = Just Refl++    match IndexAny IndexAny+      = gcast Refl  -- ???++    match IndexNil IndexNil+      = Just Refl++    match (IndexCons sl1 a1) (IndexCons sl2 a2)+      | Just Refl <- match sl1 sl2+      , Just Refl <- match a1 a2+      = Just Refl++    match (IndexHead sl1) (IndexHead sl2)+      | Just Refl <- match sl1 sl2+      = Just Refl++    match (IndexTail sl1) (IndexTail sl2)+      | Just Refl <- match sl1 sl2+      = Just Refl++    match (IndexSlice sliceIndex1 ix1 sh1) (IndexSlice sliceIndex2 ix2 sh2)+      | Just Refl <- match ix1 ix2+      , Just Refl <- match sh1 sh2+      , Just Refl <- matchSliceRestrict sliceIndex1 sliceIndex2+      = gcast Refl  -- SliceIndex representation/surface type++    match (IndexFull sliceIndex1 ix1 sl1) (IndexFull sliceIndex2 ix2 sl2)+      | Just Refl <- match ix1 ix2+      , Just Refl <- match sl1 sl2+      , Just Refl <- matchSliceExtend sliceIndex1 sliceIndex2+      = gcast Refl  -- SliceIndex representation/surface type++    match (ToIndex sh1 i1) (ToIndex sh2 i2)+      | Just Refl <- match sh1 sh2+      , Just Refl <- match i1  i2+      = Just Refl++    match (FromIndex sh1 i1) (FromIndex sh2 i2)+      | Just Refl <- match i1  i2+      , Just Refl <- match sh1 sh2+      = Just Refl++    match (Cond p1 t1 e1) (Cond p2 t2 e2)+      | Just Refl <- match p1 p2+      , Just Refl <- match t1 t2+      , Just Refl <- match e1 e2+      = Just Refl++    match (While p1 f1 x1) (While p2 f2 x2)+      | Just Refl <- match x1 x2+      , Just Refl <- matchPreOpenFun matchAcc hashAcc p1 p2+      , Just Refl <- matchPreOpenFun matchAcc hashAcc f1 f2+      = Just Refl++    match (PrimConst c1) (PrimConst c2)+      = matchPrimConst c1 c2++    match (PrimApp f1 x1) (PrimApp f2 x2)+      | Just x1'  <- commutes hashAcc f1 x1+      , Just x2'  <- commutes hashAcc f2 x2+      , Just Refl <- match        x1' x2'+      , Just Refl <- matchPrimFun f1  f2+      = Just Refl++      | Just Refl <- match x1 x2+      , Just Refl <- matchPrimFun f1 f2+      = Just Refl++    match (Index a1 x1) (Index a2 x2)+      | Just Refl <- matchAcc a1 a2     -- should only be array indices+      , Just Refl <- match    x1 x2+      = Just Refl++    match (LinearIndex a1 x1) (LinearIndex a2 x2)+      | Just Refl <- matchAcc a1 a2+      , Just Refl <- match    x1 x2+      = Just Refl++    match (Shape a1) (Shape a2)+      | Just Refl <- matchAcc a1 a2     -- should only be array indices+      = Just Refl++    match (ShapeSize sh1) (ShapeSize sh2)+      | Just Refl <- match sh1 sh2+      = Just Refl++    match (Intersect sa1 sb1) (Intersect sa2 sb2)+      | Just Refl <- match sa1 sa2+      , Just Refl <- match sb1 sb2+      = Just Refl++    match (Union sa1 sb1) (Union sa2 sb2)+      | Just Refl <- match sa1 sa2+      , Just Refl <- match sb1 sb2+      = Just Refl++    match _ _+      = Nothing+++-- Match scalar functions+--+matchOpenFun+    :: OpenFun env aenv s+    -> OpenFun env aenv t+    -> Maybe (s :~: t)+matchOpenFun = matchPreOpenFun matchOpenAcc hashOpenAcc++matchPreOpenFun+    :: MatchAcc acc+    -> HashAcc  acc+    -> PreOpenFun acc env aenv s+    -> PreOpenFun acc env aenv t+    -> Maybe (s :~: t)+matchPreOpenFun m h (Lam s) (Lam t)+  | Just Refl <- matchEnvTop         s t+  , Just Refl <- matchPreOpenFun m h s t+  = Just Refl+  where+    matchEnvTop :: (Elt s, Elt t) => PreOpenFun acc (env, s) aenv f -> PreOpenFun acc (env, t) aenv g -> Maybe (s :~: t)+    matchEnvTop _ _ = gcast Refl  -- ???++matchPreOpenFun m h (Body s) (Body t) = matchPreOpenExp m h s t+matchPreOpenFun _ _ _        _        = Nothing++-- Matching constants+--+matchConst :: TupleType a -> a -> a -> Bool+matchConst UnitTuple         ()      ()      = True+matchConst (SingleTuple ty)  a       b       = evalEq ty (a,b)+matchConst (PairTuple ta tb) (a1,b1) (a2,b2) = matchConst ta a1 a2 && matchConst tb b1 b2++evalEq :: ScalarType a -> (a, a) -> Bool+evalEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (==)+evalEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (==)+evalEq (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (==)+++-- Environment projection indices+--+matchIdx :: Idx env s -> Idx env t -> Maybe (s :~: t)+matchIdx ZeroIdx     ZeroIdx     = Just Refl+matchIdx (SuccIdx u) (SuccIdx v) = matchIdx u v+matchIdx _           _           = Nothing+++-- Tuple projection indices. Given the same tuple expression structure (tup),+-- check that the indices project identical elements.+--+matchTupleIdx :: TupleIdx tup s -> TupleIdx tup t -> Maybe (s :~: t)+matchTupleIdx ZeroTupIdx     ZeroTupIdx     = Just Refl+matchTupleIdx (SuccTupIdx s) (SuccTupIdx t) = matchTupleIdx s t+matchTupleIdx _              _              = Nothing++-- Tuples+--+matchTuple+    :: MatchAcc acc+    -> HashAcc  acc+    -> Tuple (PreOpenExp acc env aenv) s+    -> Tuple (PreOpenExp acc env aenv) t+    -> Maybe (s :~: t)+matchTuple _ _ NilTup          NilTup           = Just Refl+matchTuple m h (SnocTup t1 e1) (SnocTup t2 e2)+  | Just Refl <- matchTuple      m h t1 t2+  , Just Refl <- matchPreOpenExp m h e1 e2+  = Just Refl++matchTuple _ _ _               _                = Nothing+++-- Slice specifications+--+matchSliceRestrict+    :: SliceIndex slix s co  sh+    -> SliceIndex slix t co' sh+    -> Maybe (s :~: t)+matchSliceRestrict SliceNil SliceNil+  = Just Refl++matchSliceRestrict (SliceAll   sl1) (SliceAll   sl2)+  | Just Refl <- matchSliceRestrict sl1 sl2+  = Just Refl++matchSliceRestrict (SliceFixed sl1) (SliceFixed sl2)+  | Just Refl <- matchSliceRestrict sl1 sl2+  = Just Refl++matchSliceRestrict _ _+  = Nothing+++matchSliceExtend+    :: SliceIndex slix sl co  s+    -> SliceIndex slix sl co' t+    -> Maybe (s :~: t)+matchSliceExtend SliceNil SliceNil+  = Just Refl++matchSliceExtend (SliceAll   sl1) (SliceAll   sl2)+  | Just Refl <- matchSliceExtend sl1 sl2+  = Just Refl++matchSliceExtend (SliceFixed sl1) (SliceFixed sl2)+  | Just Refl <- matchSliceExtend sl1 sl2+  = Just Refl++matchSliceExtend _ _+  = Nothing+++-- Primitive constants and functions+--+matchPrimConst :: PrimConst s -> PrimConst t -> Maybe (s :~: t)+matchPrimConst (PrimMinBound s) (PrimMinBound t) = matchBoundedType s t+matchPrimConst (PrimMaxBound s) (PrimMaxBound t) = matchBoundedType s t+matchPrimConst (PrimPi s)       (PrimPi t)       = matchFloatingType s t+matchPrimConst _                _                = Nothing+++-- Covariant function matching+--+matchPrimFun :: PrimFun (a -> s) -> PrimFun (a -> t) -> Maybe (s :~: t)+matchPrimFun (PrimAdd _)                (PrimAdd _)                = Just Refl+matchPrimFun (PrimSub _)                (PrimSub _)                = Just Refl+matchPrimFun (PrimMul _)                (PrimMul _)                = Just Refl+matchPrimFun (PrimNeg _)                (PrimNeg _)                = Just Refl+matchPrimFun (PrimAbs _)                (PrimAbs _)                = Just Refl+matchPrimFun (PrimSig _)                (PrimSig _)                = Just Refl+matchPrimFun (PrimQuot _)               (PrimQuot _)               = Just Refl+matchPrimFun (PrimRem _)                (PrimRem _)                = Just Refl+matchPrimFun (PrimQuotRem _)            (PrimQuotRem _)            = Just Refl+matchPrimFun (PrimIDiv _)               (PrimIDiv _)               = Just Refl+matchPrimFun (PrimMod _)                (PrimMod _)                = Just Refl+matchPrimFun (PrimDivMod _)             (PrimDivMod _)             = Just Refl+matchPrimFun (PrimBAnd _)               (PrimBAnd _)               = Just Refl+matchPrimFun (PrimBOr _)                (PrimBOr _)                = Just Refl+matchPrimFun (PrimBXor _)               (PrimBXor _)               = Just Refl+matchPrimFun (PrimBNot _)               (PrimBNot _)               = Just Refl+matchPrimFun (PrimBShiftL _)            (PrimBShiftL _)            = Just Refl+matchPrimFun (PrimBShiftR _)            (PrimBShiftR _)            = Just Refl+matchPrimFun (PrimBRotateL _)           (PrimBRotateL _)           = Just Refl+matchPrimFun (PrimBRotateR _)           (PrimBRotateR _)           = Just Refl+matchPrimFun (PrimPopCount _)           (PrimPopCount _)           = Just Refl+matchPrimFun (PrimCountLeadingZeros _)  (PrimCountLeadingZeros _)  = Just Refl+matchPrimFun (PrimCountTrailingZeros _) (PrimCountTrailingZeros _) = Just Refl+matchPrimFun (PrimFDiv _)               (PrimFDiv _)               = Just Refl+matchPrimFun (PrimRecip _)              (PrimRecip _)              = Just Refl+matchPrimFun (PrimSin _)                (PrimSin _)                = Just Refl+matchPrimFun (PrimCos _)                (PrimCos _)                = Just Refl+matchPrimFun (PrimTan _)                (PrimTan _)                = Just Refl+matchPrimFun (PrimAsin _)               (PrimAsin _)               = Just Refl+matchPrimFun (PrimAcos _)               (PrimAcos _)               = Just Refl+matchPrimFun (PrimAtan _)               (PrimAtan _)               = Just Refl+matchPrimFun (PrimSinh _)               (PrimSinh _)               = Just Refl+matchPrimFun (PrimCosh _)               (PrimCosh _)               = Just Refl+matchPrimFun (PrimTanh _)               (PrimTanh _)               = Just Refl+matchPrimFun (PrimAsinh _)              (PrimAsinh _)              = Just Refl+matchPrimFun (PrimAcosh _)              (PrimAcosh _)              = Just Refl+matchPrimFun (PrimAtanh _)              (PrimAtanh _)              = Just Refl+matchPrimFun (PrimExpFloating _)        (PrimExpFloating _)        = Just Refl+matchPrimFun (PrimSqrt _)               (PrimSqrt _)               = Just Refl+matchPrimFun (PrimLog _)                (PrimLog _)                = Just Refl+matchPrimFun (PrimFPow _)               (PrimFPow _)               = Just Refl+matchPrimFun (PrimLogBase _)            (PrimLogBase _)            = Just Refl+matchPrimFun (PrimAtan2 _)              (PrimAtan2 _)              = Just Refl+matchPrimFun (PrimTruncate _ s)         (PrimTruncate _ t)         = matchIntegralType s t+matchPrimFun (PrimRound _ s)            (PrimRound _ t)            = matchIntegralType s t+matchPrimFun (PrimFloor _ s)            (PrimFloor _ t)            = matchIntegralType s t+matchPrimFun (PrimCeiling _ s)          (PrimCeiling _ t)          = matchIntegralType s t+matchPrimFun (PrimIsNaN _)              (PrimIsNaN _)              = Just Refl+matchPrimFun (PrimLt _)                 (PrimLt _)                 = Just Refl+matchPrimFun (PrimGt _)                 (PrimGt _)                 = Just Refl+matchPrimFun (PrimLtEq _)               (PrimLtEq _)               = Just Refl+matchPrimFun (PrimGtEq _)               (PrimGtEq _)               = Just Refl+matchPrimFun (PrimEq _)                 (PrimEq _)                 = Just Refl+matchPrimFun (PrimNEq _)                (PrimNEq _)                = Just Refl+matchPrimFun (PrimMax _)                (PrimMax _)                = Just Refl+matchPrimFun (PrimMin _)                (PrimMin _)                = Just Refl+matchPrimFun (PrimFromIntegral _ s)     (PrimFromIntegral _ t)     = matchNumType s t+matchPrimFun (PrimToFloating _ s)       (PrimToFloating _ t)       = matchFloatingType s t+matchPrimFun (PrimCoerce _ s)           (PrimCoerce _ t)           = matchScalarType s t+matchPrimFun PrimLAnd                   PrimLAnd                   = Just Refl+matchPrimFun PrimLOr                    PrimLOr                    = Just Refl+matchPrimFun PrimLNot                   PrimLNot                   = Just Refl+matchPrimFun PrimOrd                    PrimOrd                    = Just Refl+matchPrimFun PrimChr                    PrimChr                    = Just Refl+matchPrimFun PrimBoolToInt              PrimBoolToInt              = Just Refl+matchPrimFun _                          _                          = Nothing+++-- Contravariant function matching+--+matchPrimFun' :: PrimFun (s -> a) -> PrimFun (t -> a) -> Maybe (s :~: t)+matchPrimFun' (PrimAdd _)                (PrimAdd _)                = Just Refl+matchPrimFun' (PrimSub _)                (PrimSub _)                = Just Refl+matchPrimFun' (PrimMul _)                (PrimMul _)                = Just Refl+matchPrimFun' (PrimNeg _)                (PrimNeg _)                = Just Refl+matchPrimFun' (PrimAbs _)                (PrimAbs _)                = Just Refl+matchPrimFun' (PrimSig _)                (PrimSig _)                = Just Refl+matchPrimFun' (PrimQuot _)               (PrimQuot _)               = Just Refl+matchPrimFun' (PrimRem _)                (PrimRem _)                = Just Refl+matchPrimFun' (PrimQuotRem _)            (PrimQuotRem _)            = Just Refl+matchPrimFun' (PrimIDiv _)               (PrimIDiv _)               = Just Refl+matchPrimFun' (PrimMod _)                (PrimMod _)                = Just Refl+matchPrimFun' (PrimDivMod _)             (PrimDivMod _)             = Just Refl+matchPrimFun' (PrimBAnd _)               (PrimBAnd _)               = Just Refl+matchPrimFun' (PrimBOr _)                (PrimBOr _)                = Just Refl+matchPrimFun' (PrimBXor _)               (PrimBXor _)               = Just Refl+matchPrimFun' (PrimBNot _)               (PrimBNot _)               = Just Refl+matchPrimFun' (PrimBShiftL _)            (PrimBShiftL _)            = Just Refl+matchPrimFun' (PrimBShiftR _)            (PrimBShiftR _)            = Just Refl+matchPrimFun' (PrimBRotateL _)           (PrimBRotateL _)           = Just Refl+matchPrimFun' (PrimBRotateR _)           (PrimBRotateR _)           = Just Refl+matchPrimFun' (PrimPopCount s)           (PrimPopCount t)           = matchIntegralType s t+matchPrimFun' (PrimCountLeadingZeros s)  (PrimCountLeadingZeros t)  = matchIntegralType s t+matchPrimFun' (PrimCountTrailingZeros s) (PrimCountTrailingZeros t) = matchIntegralType s t+matchPrimFun' (PrimFDiv _)               (PrimFDiv _)               = Just Refl+matchPrimFun' (PrimRecip _)              (PrimRecip _)              = Just Refl+matchPrimFun' (PrimSin _)                (PrimSin _)                = Just Refl+matchPrimFun' (PrimCos _)                (PrimCos _)                = Just Refl+matchPrimFun' (PrimTan _)                (PrimTan _)                = Just Refl+matchPrimFun' (PrimAsin _)               (PrimAsin _)               = Just Refl+matchPrimFun' (PrimAcos _)               (PrimAcos _)               = Just Refl+matchPrimFun' (PrimAtan _)               (PrimAtan _)               = Just Refl+matchPrimFun' (PrimSinh _)               (PrimSinh _)               = Just Refl+matchPrimFun' (PrimCosh _)               (PrimCosh _)               = Just Refl+matchPrimFun' (PrimTanh _)               (PrimTanh _)               = Just Refl+matchPrimFun' (PrimAsinh _)              (PrimAsinh _)              = Just Refl+matchPrimFun' (PrimAcosh _)              (PrimAcosh _)              = Just Refl+matchPrimFun' (PrimAtanh _)              (PrimAtanh _)              = Just Refl+matchPrimFun' (PrimExpFloating _)        (PrimExpFloating _)        = Just Refl+matchPrimFun' (PrimSqrt _)               (PrimSqrt _)               = Just Refl+matchPrimFun' (PrimLog _)                (PrimLog _)                = Just Refl+matchPrimFun' (PrimFPow _)               (PrimFPow _)               = Just Refl+matchPrimFun' (PrimLogBase _)            (PrimLogBase _)            = Just Refl+matchPrimFun' (PrimAtan2 _)              (PrimAtan2 _)              = Just Refl+matchPrimFun' (PrimTruncate s _)         (PrimTruncate t _)         = matchFloatingType s t+matchPrimFun' (PrimRound s _)            (PrimRound t _)            = matchFloatingType s t+matchPrimFun' (PrimFloor s _)            (PrimFloor t _)            = matchFloatingType s t+matchPrimFun' (PrimCeiling s _)          (PrimCeiling t _)          = matchFloatingType s t+matchPrimFun' (PrimIsNaN s)              (PrimIsNaN t)              = matchFloatingType s t+matchPrimFun' (PrimMax _)                (PrimMax _)                = Just Refl+matchPrimFun' (PrimMin _)                (PrimMin _)                = Just Refl+matchPrimFun' (PrimFromIntegral s _)     (PrimFromIntegral t _)     = matchIntegralType s t+matchPrimFun' (PrimToFloating s _)       (PrimToFloating t _)       = matchNumType s t+matchPrimFun' (PrimCoerce s _)           (PrimCoerce t _)           = matchScalarType s t+matchPrimFun' PrimLAnd                   PrimLAnd                   = Just Refl+matchPrimFun' PrimLOr                    PrimLOr                    = Just Refl+matchPrimFun' PrimLNot                   PrimLNot                   = Just Refl+matchPrimFun' PrimOrd                    PrimOrd                    = Just Refl+matchPrimFun' PrimChr                    PrimChr                    = Just Refl+matchPrimFun' PrimBoolToInt              PrimBoolToInt              = Just Refl+matchPrimFun' (PrimLt s) (PrimLt t)+  | Just Refl <- matchScalarType s t+  = Just Refl++matchPrimFun' (PrimGt s) (PrimGt t)+  | Just Refl <- matchScalarType s t+  = Just Refl++matchPrimFun' (PrimLtEq s) (PrimLtEq t)+  | Just Refl <- matchScalarType s t+  = Just Refl++matchPrimFun' (PrimGtEq s) (PrimGtEq t)+  | Just Refl <- matchScalarType s t+  = Just Refl++matchPrimFun' (PrimEq s) (PrimEq t)+  | Just Refl <- matchScalarType s t+  = Just Refl++matchPrimFun' (PrimNEq s) (PrimNEq t)+  | Just Refl <- matchScalarType s t+  = Just Refl++matchPrimFun' _ _+  = Nothing+++-- Match reified types+--+matchTupleType :: TupleType s -> TupleType t -> Maybe (s :~: t)+matchTupleType UnitTuple         UnitTuple         = Just Refl+matchTupleType (SingleTuple s)   (SingleTuple t)   = matchScalarType s t+matchTupleType (PairTuple s1 s2) (PairTuple t1 t2)+  | Just Refl <- matchTupleType s1 t1+  , Just Refl <- matchTupleType s2 t2+  = Just Refl++matchTupleType _ _+  = Nothing+++-- Match reified type dictionaries+--+matchScalarType :: ScalarType s -> ScalarType t -> Maybe (s :~: t)+matchScalarType (NumScalarType s)    (NumScalarType t)    = matchNumType s t+matchScalarType (NonNumScalarType s) (NonNumScalarType t) = matchNonNumType s t+matchScalarType _                    _                    = Nothing++matchNumType :: NumType s -> NumType t -> Maybe (s :~: t)+matchNumType (IntegralNumType s) (IntegralNumType t) = matchIntegralType s t+matchNumType (FloatingNumType s) (FloatingNumType t) = matchFloatingType s t+matchNumType _                   _                   = Nothing++matchBoundedType :: BoundedType s -> BoundedType t -> Maybe (s :~: t)+matchBoundedType (IntegralBoundedType s) (IntegralBoundedType t) = matchIntegralType s t+matchBoundedType (NonNumBoundedType s)   (NonNumBoundedType t)   = matchNonNumType s t+matchBoundedType _                       _                       = Nothing++matchIntegralType :: IntegralType s -> IntegralType t -> Maybe (s :~: t)+matchIntegralType (TypeInt _)     (TypeInt _)     = Just Refl+matchIntegralType (TypeInt8 _)    (TypeInt8 _)    = Just Refl+matchIntegralType (TypeInt16 _)   (TypeInt16 _)   = Just Refl+matchIntegralType (TypeInt32 _)   (TypeInt32 _)   = Just Refl+matchIntegralType (TypeInt64 _)   (TypeInt64 _)   = Just Refl+matchIntegralType (TypeWord _)    (TypeWord _)    = Just Refl+matchIntegralType (TypeWord8 _)   (TypeWord8 _)   = Just Refl+matchIntegralType (TypeWord16 _)  (TypeWord16 _)  = Just Refl+matchIntegralType (TypeWord32 _)  (TypeWord32 _)  = Just Refl+matchIntegralType (TypeWord64 _)  (TypeWord64 _)  = Just Refl+matchIntegralType (TypeCShort _)  (TypeCShort _)  = Just Refl+matchIntegralType (TypeCUShort _) (TypeCUShort _) = Just Refl+matchIntegralType (TypeCInt _)    (TypeCInt _)    = Just Refl+matchIntegralType (TypeCUInt _)   (TypeCUInt _)   = Just Refl+matchIntegralType (TypeCLong _)   (TypeCLong _)   = Just Refl+matchIntegralType (TypeCULong _)  (TypeCULong _)  = Just Refl+matchIntegralType (TypeCLLong _)  (TypeCLLong _)  = Just Refl+matchIntegralType (TypeCULLong _) (TypeCULLong _) = Just Refl+matchIntegralType _               _               = Nothing++matchFloatingType :: FloatingType s -> FloatingType t -> Maybe (s :~: t)+matchFloatingType (TypeFloat _)   (TypeFloat _)   = Just Refl+matchFloatingType (TypeDouble _)  (TypeDouble _)  = Just Refl+matchFloatingType (TypeCFloat _)  (TypeCFloat _)  = Just Refl+matchFloatingType (TypeCDouble _) (TypeCDouble _) = Just Refl+matchFloatingType _               _               = Nothing++matchNonNumType :: NonNumType s -> NonNumType t -> Maybe (s :~: t)+matchNonNumType (TypeBool _)   (TypeBool _)   = Just Refl+matchNonNumType (TypeChar _)   (TypeChar _)   = Just Refl+matchNonNumType (TypeCChar _)  (TypeCChar _)  = Just Refl+matchNonNumType (TypeCSChar _) (TypeCSChar _) = Just Refl+matchNonNumType (TypeCUChar _) (TypeCUChar _) = Just Refl+matchNonNumType _              _              = Nothing+++-- Discriminate binary functions that commute, and if so return the operands in+-- a stable ordering such that matching recognises expressions modulo+-- commutativity.+--+commutes+    :: forall acc env aenv a r.+       HashAcc acc+    -> PrimFun (a -> r)+    -> PreOpenExp acc env aenv a+    -> Maybe (PreOpenExp acc env aenv a)+commutes h f x = case f of+  PrimAdd _     -> Just (swizzle x)+  PrimMul _     -> Just (swizzle x)+  PrimBAnd _    -> Just (swizzle x)+  PrimBOr _     -> Just (swizzle x)+  PrimBXor _    -> Just (swizzle x)+  PrimEq _      -> Just (swizzle x)+  PrimNEq _     -> Just (swizzle x)+  PrimMax _     -> Just (swizzle x)+  PrimMin _     -> Just (swizzle x)+  PrimLAnd      -> Just (swizzle x)+  PrimLOr       -> Just (swizzle x)+  _             -> Nothing+  where+    swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a')+    swizzle exp+      | Tuple (NilTup `SnocTup` a `SnocTup` b)  <- exp+      , hashPreOpenExp h a > hashPreOpenExp h b = Tuple (NilTup `SnocTup` b `SnocTup` a)+      --+      | otherwise                               = exp+++-- Hashing+-- =======++hashIdx :: Idx env t -> Int+hashIdx = hash . idxToInt++hashTupleIdx :: TupleIdx tup e -> Int+hashTupleIdx = hash . tupleIdxToInt+++-- Array computations+-- ------------------++type HashAcc acc = forall aenv a. acc aenv a -> Int+++hashOpenAcc :: OpenAcc aenv arrs -> Int+hashOpenAcc (OpenAcc pacc) = hashPreOpenAcc hashOpenAcc pacc++{--+hashPreOpenSeq :: forall acc aenv senv arrs. HashAcc acc -> PreOpenSeq acc aenv senv arrs -> Int+hashPreOpenSeq hashAcc s =+  let+    hashA :: Int -> acc aenv' a -> Int+    hashA salt = hashWithSalt salt . hashAcc++    hashE :: Int -> PreOpenExp acc env' aenv' e -> Int+    hashE salt = hashWithSalt salt . hashPreOpenExp hashAcc++    hashAF :: Int -> PreOpenAfun acc aenv' f -> Int+    hashAF salt = hashWithSalt salt . hashAfun hashAcc++    hashF :: Int -> PreOpenFun acc env' aenv' f -> Int+    hashF salt = hashWithSalt salt . hashPreOpenFun hashAcc++    hashS :: Int -> PreOpenSeq acc aenv senv' arrs' -> Int+    hashS salt = hashWithSalt salt . hashPreOpenSeq hashAcc++    hashVar :: Int -> Idx senv' a -> Int+    hashVar salt = hashWithSalt salt . idxToInt++    hashP :: Int -> Producer acc aenv senv a -> Int+    hashP salt p =+      case p of+        StreamIn arrs       -> unsafePerformIO $! hashStableName `fmap` makeStableName arrs+        ToSeq spec _ acc    -> hashWithSalt salt "ToSeq"         `hashA`  acc `hashWithSalt` show spec+        MapSeq f x          -> hashWithSalt salt "MapSeq"        `hashAF` f   `hashVar` x+        ChunkedMapSeq f x   -> hashWithSalt salt "ChunkedMapSeq" `hashAF` f   `hashVar` x+        ZipWithSeq f x y    -> hashWithSalt salt "ZipWithSeq"    `hashAF` f   `hashVar` x `hashVar` y+        ScanSeq f e x       -> hashWithSalt salt "ScanSeq"       `hashF`  f   `hashE`   e `hashVar` x++    hashC :: Int -> Consumer acc aenv senv' a -> Int+    hashC salt c =+      case c of+        FoldSeq f e x          -> hashWithSalt salt "FoldSeq"        `hashF`  f `hashE` e   `hashVar` x+        FoldSeqFlatten f acc x -> hashWithSalt salt "FoldSeqFlatten" `hashAF` f `hashA` acc `hashVar` x+        Stuple t               -> hash "Stuple" `hashWithSalt` hashAtuple (hashC salt) t++  in case s of+    Producer   p s' -> hash "Producer"   `hashP` p `hashS` s'+    Consumer   c    -> hash "Consumer"   `hashC` c+    Reify      ix   -> hash "Reify"      `hashVar` ix+--}+++hashPreOpenAcc :: forall acc aenv arrs. HashAcc acc -> PreOpenAcc acc aenv arrs -> Int+hashPreOpenAcc hashAcc pacc =+  let+    hashA :: Int -> acc aenv' a -> Int+    hashA salt = hashWithSalt salt . hashAcc++    hashE :: Int -> PreOpenExp acc env' aenv' e -> Int+    hashE salt = hashWithSalt salt . hashPreOpenExp hashAcc++    hashF :: Int -> PreOpenFun acc env' aenv' f -> Int+    hashF salt = hashWithSalt salt . hashPreOpenFun hashAcc++    -- hashS :: Int -> PreOpenSeq acc aenv senv arrs -> Int+    -- hashS salt = hashWithSalt salt . hashPreOpenSeq hashAcc++  in case pacc of+    Alet bnd body               -> hash "Alet"          `hashA` bnd `hashA` body+    Avar v                      -> hash "Avar"          `hashWithSalt` hashIdx v+    Atuple t                    -> hash "Atuple"        `hashWithSalt` hashAtuple hashAcc t+    Aprj ix a                   -> hash "Aprj"          `hashWithSalt` hashTupleIdx ix    `hashA` a+    Apply f a                   -> hash "Apply"         `hashWithSalt` hashAfun hashAcc f `hashA` a+    Aforeign _ f a              -> hash "Aforeign"      `hashWithSalt` hashAfun hashAcc f `hashA` a+    Use a                       -> hash "Use"           `hashWithSalt` hashArrays (arrays (undefined::arrs)) a+    Awhile p f a                -> hash "Awhile"        `hashWithSalt` hashAfun hashAcc f `hashWithSalt` hashAfun hashAcc p `hashA` a+    Unit e                      -> hash "Unit"          `hashE` e+    Generate e f                -> hash "Generate"      `hashE` e  `hashF` f+    Acond e a1 a2               -> hash "Acond"         `hashE` e  `hashA` a1 `hashA` a2+    Reshape sh a                -> hash "Reshape"       `hashE` sh `hashA` a+    Transform sh f1 f2 a        -> hash "Transform"     `hashE` sh `hashF` f1 `hashF` f2 `hashA` a+    Replicate spec ix a         -> hash "Replicate"     `hashE` ix `hashA` a  `hashWithSalt` show spec+    Slice spec a ix             -> hash "Slice"         `hashE` ix `hashA` a  `hashWithSalt` show spec+    Map f a                     -> hash "Map"           `hashF` f  `hashA` a+    ZipWith f a1 a2             -> hash "ZipWith"       `hashF` f  `hashA` a1 `hashA` a2+    Fold f e a                  -> hash "Fold"          `hashF` f  `hashE` e  `hashA` a+    Fold1 f a                   -> hash "Fold1"         `hashF` f  `hashA` a+    FoldSeg f e a s             -> hash "FoldSeg"       `hashF` f  `hashE` e  `hashA` a  `hashA` s+    Fold1Seg f a s              -> hash "Fold1Seg"      `hashF` f  `hashA` a  `hashA` s+    Scanl f e a                 -> hash "Scanl"         `hashF` f  `hashE` e  `hashA` a+    Scanl' f e a                -> hash "Scanl'"        `hashF` f  `hashE` e  `hashA` a+    Scanl1 f a                  -> hash "Scanl1"        `hashF` f  `hashA` a+    Scanr f e a                 -> hash "Scanr"         `hashF` f  `hashE` e  `hashA` a+    Scanr' f e a                -> hash "Scanr'"        `hashF` f  `hashE` e  `hashA` a+    Scanr1 f a                  -> hash "Scanr1"        `hashF` f  `hashA` a+    Backpermute sh f a          -> hash "Backpermute"   `hashF` f  `hashE` sh `hashA` a+    Permute f1 a1 f2 a2         -> hash "Permute"       `hashF` f1 `hashA` a1 `hashF` f2 `hashA` a2+    Stencil f b a               -> hash "Stencil"       `hashF` f  `hashA` a             `hashWithSalt` hashBoundary a  b+    Stencil2 f b1 a1 b2 a2      -> hash "Stencil2"      `hashF` f  `hashA` a1 `hashA` a2 `hashWithSalt` hashBoundary a1 b1 `hashWithSalt` hashBoundary a2 b2+    -- Collect s                   -> hash "Seq"           `hashS` s+++hashArrays :: ArraysR a -> a -> Int+hashArrays ArraysRunit         ()       = hash ()+hashArrays (ArraysRpair r1 r2) (a1, a2) = hash ( hashArrays r1 a1, hashArrays r2 a2)+hashArrays ArraysRarray        ad       = unsafePerformIO $! hashStableName `fmap` makeStableName ad++hashAtuple :: HashAcc acc -> Atuple (acc aenv) a -> Int+hashAtuple _ NilAtup            = hash "NilAtup"+hashAtuple h (SnocAtup t a)     = hash "SnocAtup"       `hashWithSalt` hashAtuple h t `hashWithSalt` h a++hashAfun :: HashAcc acc -> PreOpenAfun acc aenv f -> Int+hashAfun h (Abody b)            = hash "Abody"          `hashWithSalt` h b+hashAfun h (Alam f)             = hash "Alam"           `hashWithSalt` hashAfun h f++hashBoundary :: forall acc aenv sh e. Elt e => acc aenv (Array sh e) -> Boundary (EltRepr e) -> Int+hashBoundary _ Wrap             = hash "Wrap"+hashBoundary _ Clamp            = hash "Clamp"+hashBoundary _ Mirror           = hash "Mirror"+hashBoundary _ (Constant c)     = hash "Constant"       `hashWithSalt` show (toElt c :: e)+++-- Scalar expressions+-- ------------------++hashOpenExp :: OpenExp env aenv exp -> Int+hashOpenExp = hashPreOpenExp hashOpenAcc++hashPreOpenExp :: forall acc env aenv exp. HashAcc acc -> PreOpenExp acc env aenv exp -> Int+hashPreOpenExp hashAcc exp =+  let+    hashA :: Int -> acc aenv' a -> Int+    hashA salt = hashWithSalt salt . hashAcc++    hashE :: Int -> PreOpenExp acc env' aenv' e -> Int+    hashE salt = hashWithSalt salt . hashPreOpenExp hashAcc++  in case exp of+    Let bnd body                -> hash "Let"           `hashE` bnd `hashE` body+    Var ix                      -> hash "Var"           `hashWithSalt` hashIdx ix+    Const c                     -> hash "Const"         `hashWithSalt` show (toElt c :: exp)+    Tuple t                     -> hash "Tuple"         `hashWithSalt` hashTuple hashAcc t+    Prj i e                     -> hash "Prj"           `hashWithSalt` hashTupleIdx i `hashE` e+    IndexAny                    -> hash "IndexAny"+    IndexNil                    -> hash "IndexNil"+    IndexCons sl a              -> hash "IndexCons"     `hashE` sl `hashE` a+    IndexHead sl                -> hash "IndexHead"     `hashE` sl+    IndexTail sl                -> hash "IndexTail"     `hashE` sl+    IndexSlice spec ix sh       -> hash "IndexSlice"    `hashE` ix `hashE` sh `hashWithSalt` show spec+    IndexFull  spec ix sl       -> hash "IndexFull"     `hashE` ix `hashE` sl `hashWithSalt` show spec+    ToIndex sh i                -> hash "ToIndex"       `hashE` sh `hashE` i+    FromIndex sh i              -> hash "FromIndex"     `hashE` sh `hashE` i+    Cond c t e                  -> hash "Cond"          `hashE` c  `hashE` t  `hashE` e+    While p f x                 -> hash "While"         `hashWithSalt` hashPreOpenFun hashAcc p  `hashWithSalt` hashPreOpenFun hashAcc f  `hashE` x+    PrimApp f x                 -> hash "PrimApp"       `hashWithSalt` hashPrimFun f `hashE` fromMaybe x (commutes hashAcc f x)+    PrimConst c                 -> hash "PrimConst"     `hashWithSalt` hashPrimConst c+    Index a ix                  -> hash "Index"         `hashA` a  `hashE` ix+    LinearIndex a ix            -> hash "LinearIndex"   `hashA` a  `hashE` ix+    Shape a                     -> hash "Shape"         `hashA` a+    ShapeSize sh                -> hash "ShapeSize"     `hashE` sh+    Intersect sa sb             -> hash "Intersect"     `hashE` sa `hashE` sb+    Union sa sb                 -> hash "Union"         `hashE` sa `hashE` sb+    Foreign _ f e               -> hash "Foreign"       `hashWithSalt` hashPreOpenFun hashAcc f `hashE` e+++hashPreOpenFun :: HashAcc acc -> PreOpenFun acc env aenv f -> Int+hashPreOpenFun h (Body e)       = hash "Body"           `hashWithSalt` hashPreOpenExp h e+hashPreOpenFun h (Lam f)        = hash "Lam"            `hashWithSalt` hashPreOpenFun h f++hashTuple :: HashAcc acc -> Tuple (PreOpenExp acc env aenv) e -> Int+hashTuple _ NilTup              = hash "NilTup"+hashTuple h (SnocTup t e)       = hash "SnocTup"        `hashWithSalt` hashTuple h t `hashWithSalt` hashPreOpenExp h e+++hashPrimConst :: PrimConst c -> Int+hashPrimConst PrimMinBound{}    = hash "PrimMinBound"+hashPrimConst PrimMaxBound{}    = hash "PrimMaxBound"+hashPrimConst PrimPi{}          = hash "PrimPi"++hashPrimFun :: PrimFun f -> Int+hashPrimFun PrimAdd{}                = hash "PrimAdd"+hashPrimFun PrimSub{}                = hash "PrimSub"+hashPrimFun PrimMul{}                = hash "PrimMul"+hashPrimFun PrimNeg{}                = hash "PrimNeg"+hashPrimFun PrimAbs{}                = hash "PrimAbs"+hashPrimFun PrimSig{}                = hash "PrimSig"+hashPrimFun PrimQuot{}               = hash "PrimQuot"+hashPrimFun PrimRem{}                = hash "PrimRem"+hashPrimFun PrimQuotRem{}            = hash "PrimQuotRem"+hashPrimFun PrimIDiv{}               = hash "PrimIDiv"+hashPrimFun PrimMod{}                = hash "PrimMod"+hashPrimFun PrimDivMod{}             = hash "PrimDivMod"+hashPrimFun PrimBAnd{}               = hash "PrimBAnd"+hashPrimFun PrimBOr{}                = hash "PrimBOr"+hashPrimFun PrimBXor{}               = hash "PrimBXor"+hashPrimFun PrimBNot{}               = hash "PrimBNot"+hashPrimFun PrimBShiftL{}            = hash "PrimBShiftL"+hashPrimFun PrimBShiftR{}            = hash "PrimBShiftR"+hashPrimFun PrimBRotateL{}           = hash "PrimBRotateL"+hashPrimFun PrimBRotateR{}           = hash "PrimBRotateR"+hashPrimFun PrimPopCount{}           = hash "PrimPopCount"+hashPrimFun PrimCountLeadingZeros{}  = hash "PrimCountLeadingZeros"+hashPrimFun PrimCountTrailingZeros{} = hash "PrimCountTrailingZeros"+hashPrimFun PrimFDiv{}               = hash "PrimFDiv"+hashPrimFun PrimRecip{}              = hash "PrimRecip"+hashPrimFun PrimSin{}                = hash "PrimSin"+hashPrimFun PrimCos{}                = hash "PrimCos"+hashPrimFun PrimTan{}                = hash "PrimTan"+hashPrimFun PrimAsin{}               = hash "PrimAsin"+hashPrimFun PrimAcos{}               = hash "PrimAcos"+hashPrimFun PrimAtan{}               = hash "PrimAtan"+hashPrimFun PrimSinh{}               = hash "PrimSinh"+hashPrimFun PrimCosh{}               = hash "PrimCosh"+hashPrimFun PrimTanh{}               = hash "PrimTanh"+hashPrimFun PrimAsinh{}              = hash "PrimAsinh"+hashPrimFun PrimAcosh{}              = hash "PrimAcosh"+hashPrimFun PrimAtanh{}              = hash "PrimAtanh"+hashPrimFun PrimExpFloating{}        = hash "PrimExpFloating"+hashPrimFun PrimSqrt{}               = hash "PrimSqrt"+hashPrimFun PrimLog{}                = hash "PrimLog"+hashPrimFun PrimFPow{}               = hash "PrimFPow"+hashPrimFun PrimLogBase{}            = hash "PrimLogBase"+hashPrimFun PrimAtan2{}              = hash "PrimAtan2"+hashPrimFun PrimTruncate{}           = hash "PrimTruncate"+hashPrimFun PrimRound{}              = hash "PrimRound"+hashPrimFun PrimFloor{}              = hash "PrimFloor"+hashPrimFun PrimCeiling{}            = hash "PrimCeiling"+hashPrimFun PrimIsNaN{}              = hash "PrimIsNaN"+hashPrimFun PrimLt{}                 = hash "PrimLt"+hashPrimFun PrimGt{}                 = hash "PrimGt"+hashPrimFun PrimLtEq{}               = hash "PrimLtEq"+hashPrimFun PrimGtEq{}               = hash "PrimGtEq"+hashPrimFun PrimEq{}                 = hash "PrimEq"+hashPrimFun PrimNEq{}                = hash "PrimNEq"+hashPrimFun PrimMax{}                = hash "PrimMax"+hashPrimFun PrimMin{}                = hash "PrimMin"+hashPrimFun PrimFromIntegral{}       = hash "PrimFromIntegral"+hashPrimFun PrimToFloating{}         = hash "PrimToFloating"+hashPrimFun PrimCoerce{}             = hash "PrimCoerce"+hashPrimFun PrimLAnd                 = hash "PrimLAnd"+hashPrimFun PrimLOr                  = hash "PrimLOr"+hashPrimFun PrimLNot                 = hash "PrimLNot"+hashPrimFun PrimOrd                  = hash "PrimOrd"+hashPrimFun PrimChr                  = hash "PrimChr"+hashPrimFun PrimBoolToInt            = hash "PrimBoolToInt" 

@@ -1,14 +1,15 @@+{-# LANGUAGE CPP                 #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Analysis.Shape--- Copyright   : [2008..2014] Manuel M T Chakravarty, Gabriele Keller---               [2009..2014] Trevor L. McDonell+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -45,29 +46,47 @@ preAccDim k pacc =   case pacc of     Alet  _ acc          -> k acc-    Avar _               -> case arrays' (undefined :: Array sh e) of+    Avar _               -> case arrays (undefined :: Array sh e) of                               ArraysRarray -> ndim (eltType (undefined::sh))+#if __GLASGOW_HASKELL__ < 800                               _            -> error "halt, fiend!"+#endif -    Apply _ _            -> case arrays' (undefined :: Array sh e) of+    Apply _ _            -> case arrays (undefined :: Array sh e) of                               ArraysRarray -> ndim (eltType (undefined::sh))+#if __GLASGOW_HASKELL__ < 800                               _            -> error "umm, hello"+#endif -    Aforeign _ _ _      -> case arrays' (undefined :: Array sh e) of+    Aforeign _ _ _      -> case arrays (undefined :: Array sh e) of                               ArraysRarray -> ndim (eltType (undefined::sh))+#if __GLASGOW_HASKELL__ < 800                               _            -> error "I don't even like snails!"+#endif -    Atuple _             -> case arrays' (undefined :: Array sh e) of+    Atuple _             -> case arrays (undefined :: Array sh e) of                               ArraysRarray -> ndim (eltType (undefined::sh))+#if __GLASGOW_HASKELL__ < 800                               _            -> error "can we keep him?"+#endif -    Aprj _ _             -> case arrays' (undefined :: Array sh e) of+    Aprj _ _             -> case arrays (undefined :: Array sh e) of                               ArraysRarray -> ndim (eltType (undefined::sh))+#if __GLASGOW_HASKELL__ < 800                               _            -> error "inconceivable!"+#endif +{--+    Collect _            -> case arrays (undefined :: Array sh e) of+                              ArraysRarray -> ndim (eltType (undefined::sh))+#if __GLASGOW_HASKELL__ < 800+                              _            -> error "ppbbbbbt~"+#endif+--}+     Acond _ acc _        -> k acc     Awhile _ _ acc       -> k acc-    Use ((),(Array _ _)) -> ndim (eltType (undefined::sh))+    Use Array{}          -> ndim (eltType (undefined::sh))     Unit _               -> 0     Generate _ _         -> ndim (eltType (undefined::sh))     Transform _ _ _ _    -> ndim (eltType (undefined::sh))

@@ -3,12 +3,12 @@ {-# LANGUAGE TypeOperators       #-} {-# OPTIONS_HADDOCK hide #-} -- |--- Module      : Data.Array.Accelerate.CUDA.Analysis.Stencil+-- Module      : Data.Array.Accelerate.Analysis.Stencil -- Copyright   : [2010..2011] Ben Lever---               [2010..2014] Trevor L. McDonell+--               [2010..2017] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                 #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE PatternGuards       #-} {-# LANGUAGE RankNTypes          #-}@@ -6,11 +7,11 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Analysis.Type--- Copyright   : [2008..2014] Manuel M T Chakravarty, Gabriele Keller---               [2009..2014] Trevor L. McDonell+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -81,29 +82,47 @@     -- The following all contain impossible pattern matches, but GHC's type     -- checker does no grok that     ---    Avar _              -> case arrays' (undefined :: (Array sh e)) of+    Avar _              -> case arrays (undefined :: (Array sh e)) of                              ArraysRarray -> eltType (undefined::e)+#if __GLASGOW_HASKELL__ < 800                              _            -> error "When I get sad, I stop being sad and be AWESOME instead."+#endif -    Apply _ _           -> case arrays' (undefined :: Array sh e) of+    Apply _ _           -> case arrays (undefined :: Array sh e) of                              ArraysRarray -> eltType (undefined::e)+#if __GLASGOW_HASKELL__ < 800                              _            -> error "TRUE STORY."+#endif -    Atuple _            -> case arrays' (undefined :: Array sh e) of+    Atuple _            -> case arrays (undefined :: Array sh e) of                              ArraysRarray -> eltType (undefined::e)+#if __GLASGOW_HASKELL__ < 800                              _            -> error "I made you a cookie, but I eated it."+#endif -    Aprj _ _            -> case arrays' (undefined :: Array sh e) of+    Aprj _ _            -> case arrays (undefined :: Array sh e) of                              ArraysRarray -> eltType (undefined::e)+#if __GLASGOW_HASKELL__ < 800                              _            -> error "Hey look! even the leaves are falling for you."+#endif -    Aforeign _ _ _      -> case arrays' (undefined :: Array sh e) of+    Aforeign _ _ _      -> case arrays (undefined :: Array sh e) of                              ArraysRarray -> eltType (undefined::e)+#if __GLASGOW_HASKELL__ < 800                              _            -> error "Who on earth wrote all these weird error messages?"+#endif +{--+    Collect _           -> case arrays (undefined :: Array sh e) of+                             ArraysRarray -> eltType (undefined::e)+#if __GLASGOW_HASKELL__ < 800+                             _            -> error "rob you are terrible at this game"+#endif+--}+     Acond _ acc _       -> k acc     Awhile _ _ acc      -> k acc-    Use ((),a)          -> arrayType a+    Use a               -> arrayType a     Unit _              -> eltType (undefined::e)     Generate _ _        -> eltType (undefined::e)     Transform _ _ _ _   -> eltType (undefined::e)@@ -166,6 +185,7 @@     Shape _           -> eltType (undefined::t)     ShapeSize _       -> eltType (undefined::t)     Intersect _ _     -> eltType (undefined::t)+    Union _ _         -> eltType (undefined::t)     Foreign _ _ _     -> eltType (undefined::t)  

@@ -1,26 +1,19 @@-{-# LANGUAGE CPP                 #-} {-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE FlexibleInstances   #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE MagicHash           #-}-{-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving  #-} {-# LANGUAGE TemplateHaskell     #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE UnboxedTuples       #-}-{-# OPTIONS_GHC -fno-warn-missing-methods #-}-{-# OPTIONS_GHC -fno-warn-orphans         #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Array.Data--- Copyright   : [2008..2014] Manuel M T Chakravarty, Gabriele Keller---               [2008..2009] Sean Lee---               [2009..2014] Trevor L. McDonell+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -42,34 +35,37 @@   -- * Type macros   HTYPE_INT, HTYPE_WORD, HTYPE_LONG, HTYPE_UNSIGNED_LONG, HTYPE_CCHAR, +  -- * Allocator internals+  registerForeignPtrAllocator,+ ) where +-- friends+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Debug.Flags+import Data.Array.Accelerate.Debug.Trace+ -- standard libraries-import Foreign                                  ( Ptr )-import Foreign.C.Types-import Data.Bits-import Data.Functor-import Data.Typeable                            ( Typeable )+import Control.Applicative import Control.Monad-#ifdef ACCELERATE_UNSAFE_CHECKS-import qualified Data.Array.Base                as MArray ( readArray, writeArray )-#else-import qualified Data.Array.Base                as MArray ( unsafeRead, unsafeWrite )-#endif-import Data.Array.Storable.Internals-import Foreign.ForeignPtr.Unsafe-import System.IO.Unsafe-import Data.Array.MArray                        ( MArray )-import Data.Array.Base                          ( unsafeNewArray_ )+import Data.Bits+import Data.IORef+import Data.Typeable                                                ( Typeable )+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable import Language.Haskell.TH+import System.IO.Unsafe+import Text.Printf import Prelude --- friends-import Data.Array.Accelerate.Type+import GHC.Base                                                     ( Int(..), IO(..), unsafeCoerce#, newAlignedPinnedByteArray#, byteArrayContents# )+import GHC.ForeignPtr                                               ( ForeignPtr(..), ForeignPtrContents(..) ) --- Add needed Typeable instance for StorableArray----deriving instance Typeable StorableArray  -- Determine the underlying type of a Haskell CLong or CULong. --@@ -112,7 +108,7 @@  -- |Mutable array representation ---type MutableArrayData e = GArrayData (StorableArray Int) e+type MutableArrayData e = GArrayData UniqueArray e  -- Array representation in dependence on the element type, but abstracting -- over the basic array type (in particular, abstracting over mutability)@@ -194,400 +190,618 @@  class ArrayElt e where   type ArrayPtrs e+  arrayElt               :: ArrayEltR e   --   unsafeIndexArrayData   :: ArrayData e -> Int -> e   ptrsOfArrayData        :: ArrayData e -> ArrayPtrs e+  touchArrayData         :: ArrayData e -> IO ()   --   newArrayData           :: Int -> IO (MutableArrayData e)   unsafeReadArrayData    :: MutableArrayData e -> Int      -> IO e   unsafeWriteArrayData   :: MutableArrayData e -> Int -> e -> IO ()   unsafeFreezeArrayData  :: MutableArrayData e -> IO (ArrayData e)-  unsafeFreezeArrayData  = return   ptrsOfMutableArrayData :: MutableArrayData e -> IO (ArrayPtrs e)-  ptrsOfMutableArrayData = return . ptrsOfArrayData   ---  arrayElt               :: ArrayEltR e+  {-# INLINE unsafeFreezeArrayData  #-}+  {-# INLINE ptrsOfMutableArrayData #-}+  unsafeFreezeArrayData  = return+  ptrsOfMutableArrayData = return . ptrsOfArrayData  instance ArrayElt () where   type ArrayPtrs () = ()-  unsafeIndexArrayData AD_Unit i    = i `seq` ()-  ptrsOfArrayData AD_Unit           = ()-  newArrayData size                 = size `seq` return AD_Unit-  unsafeReadArrayData AD_Unit i     = i `seq` return ()-  unsafeWriteArrayData AD_Unit i () = i `seq` return ()-  arrayElt                          = ArrayEltRunit+  arrayElt          = ArrayEltRunit+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData AD_Unit i          = i `seq` ()+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData AD_Unit                 = ()+  {-# INLINE touchArrayData #-}+  touchArrayData AD_Unit                  = return ()+  {-# INLINE newArrayData #-}+  newArrayData size                       = size `seq` return AD_Unit+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData AD_Unit i           = i `seq` return ()+  {-# INLINE unsafeWriteArrayData #-}+  unsafeWriteArrayData AD_Unit i ()       = i `seq` return ()  instance ArrayElt Int where   type ArrayPtrs Int = Ptr Int-  unsafeIndexArrayData (AD_Int ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Int ba)          = storableArrayPtr ba-  newArrayData size                    = liftM AD_Int $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_Int ba) i    = unsafeReadArray ba i-  unsafeWriteArrayData (AD_Int ba) i e = unsafeWriteArray ba i e-  arrayElt                             = ArrayEltRint+  arrayElt           = ArrayEltRint+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_Int ba) i      = unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Int ba)             = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Int ba)              = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Int <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_Int ba) i       = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}+  unsafeWriteArrayData (AD_Int ba) i e    = unsafeWriteArray ba i e  instance ArrayElt Int8 where   type ArrayPtrs Int8 = Ptr Int8-  unsafeIndexArrayData (AD_Int8 ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Int8 ba)          = storableArrayPtr ba-  newArrayData size                     = liftM AD_Int8 $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_Int8 ba) i    = unsafeReadArray ba i-  unsafeWriteArrayData (AD_Int8 ba) i e = unsafeWriteArray ba i e-  arrayElt                              = ArrayEltRint8+  arrayElt            = ArrayEltRint8+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_Int8 ba) i     = unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Int8 ba)            = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Int8 ba)             = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Int8 <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_Int8 ba) i      = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}+  unsafeWriteArrayData (AD_Int8 ba) i e   = unsafeWriteArray ba i e  instance ArrayElt Int16 where   type ArrayPtrs Int16 = Ptr Int16-  unsafeIndexArrayData (AD_Int16 ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Int16 ba)          = storableArrayPtr ba-  newArrayData size                      = liftM AD_Int16 $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_Int16 ba) i    = unsafeReadArray ba i-  unsafeWriteArrayData (AD_Int16 ba) i e = unsafeWriteArray ba i e-  arrayElt                               = ArrayEltRint16+  arrayElt             = ArrayEltRint16+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_Int16 ba) i    = unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Int16 ba)           = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Int16 ba)            = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Int16 <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_Int16 ba) i     = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}+  unsafeWriteArrayData (AD_Int16 ba) i e  = unsafeWriteArray ba i e  instance ArrayElt Int32 where   type ArrayPtrs Int32 = Ptr Int32-  unsafeIndexArrayData (AD_Int32 ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Int32 ba)          = storableArrayPtr ba-  newArrayData size                      = liftM AD_Int32 $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_Int32 ba) i    = unsafeReadArray ba i-  unsafeWriteArrayData (AD_Int32 ba) i e = unsafeWriteArray ba i e-  arrayElt                               = ArrayEltRint32+  arrayElt             = ArrayEltRint32+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_Int32 ba) i    = unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Int32 ba)           = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Int32 ba)            = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Int32 <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_Int32 ba) i     = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}+  unsafeWriteArrayData (AD_Int32 ba) i e  = unsafeWriteArray ba i e  instance ArrayElt Int64 where   type ArrayPtrs Int64 = Ptr Int64-  unsafeIndexArrayData (AD_Int64 ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Int64 ba)          = storableArrayPtr ba-  newArrayData size                      = liftM AD_Int64 $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_Int64 ba) i    = unsafeReadArray ba i-  unsafeWriteArrayData (AD_Int64 ba) i e = unsafeWriteArray ba i e-  arrayElt                               = ArrayEltRint64+  arrayElt             = ArrayEltRint64+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_Int64 ba) i    = unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Int64 ba)           = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Int64 ba)            = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Int64 <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_Int64 ba) i     = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}+  unsafeWriteArrayData (AD_Int64 ba) i e  = unsafeWriteArray ba i e  instance ArrayElt Word where   type ArrayPtrs Word = Ptr Word-  unsafeIndexArrayData (AD_Word ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Word ba)          = storableArrayPtr ba-  newArrayData size                     = liftM AD_Word $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_Word ba) i    = unsafeReadArray ba i-  unsafeWriteArrayData (AD_Word ba) i e = unsafeWriteArray ba i e-  arrayElt                              = ArrayEltRword+  arrayElt            = ArrayEltRword+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_Word ba) i     = unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Word ba)            = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Word ba)             = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Word <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_Word ba) i      = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}+  unsafeWriteArrayData (AD_Word ba) i e   = unsafeWriteArray ba i e  instance ArrayElt Word8 where   type ArrayPtrs Word8 = Ptr Word8-  unsafeIndexArrayData (AD_Word8 ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Word8 ba)          = storableArrayPtr ba-  newArrayData size                      = liftM AD_Word8 $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_Word8 ba) i    = unsafeReadArray ba i-  unsafeWriteArrayData (AD_Word8 ba) i e = unsafeWriteArray ba i e-  arrayElt                               = ArrayEltRword8+  arrayElt             = ArrayEltRword8+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_Word8 ba) i    = unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Word8 ba)           = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Word8 ba)            = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Word8 <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_Word8 ba) i     = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}+  unsafeWriteArrayData (AD_Word8 ba) i e  = unsafeWriteArray ba i e  instance ArrayElt Word16 where   type ArrayPtrs Word16 = Ptr Word16+  arrayElt              = ArrayEltRword16+  {-# INLINE unsafeIndexArrayData #-}   unsafeIndexArrayData (AD_Word16 ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Word16 ba)          = storableArrayPtr ba-  newArrayData size                       = liftM AD_Word16 $ unsafeNewArray_ (0,size-1)+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Word16 ba)          = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Word16 ba)           = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Word16 <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}   unsafeReadArrayData (AD_Word16 ba) i    = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_Word16 ba) i e = unsafeWriteArray ba i e-  arrayElt                                = ArrayEltRword16  instance ArrayElt Word32 where   type ArrayPtrs Word32 = Ptr Word32+  arrayElt              = ArrayEltRword32+  {-# INLINE unsafeIndexArrayData #-}   unsafeIndexArrayData (AD_Word32 ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Word32 ba)          = storableArrayPtr ba-  newArrayData size                       = liftM AD_Word32 $ unsafeNewArray_ (0,size-1)+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Word32 ba)          = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Word32 ba)           = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Word32 <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}   unsafeReadArrayData (AD_Word32 ba) i    = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_Word32 ba) i e = unsafeWriteArray ba i e-  arrayElt                                = ArrayEltRword32  instance ArrayElt Word64 where   type ArrayPtrs Word64 = Ptr Word64+  arrayElt              = ArrayEltRword64+  {-# INLINE unsafeIndexArrayData #-}   unsafeIndexArrayData (AD_Word64 ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Word64 ba)          = storableArrayPtr ba-  newArrayData size                       = liftM AD_Word64 $ unsafeNewArray_ (0,size-1)+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Word64 ba)          = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Word64 ba)           = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Word64 <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}   unsafeReadArrayData (AD_Word64 ba) i    = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_Word64 ba) i e = unsafeWriteArray ba i e-  arrayElt                                = ArrayEltRword64  instance ArrayElt CShort where   type ArrayPtrs CShort = Ptr Int16+  arrayElt              = ArrayEltRcshort+  {-# INLINE unsafeIndexArrayData #-}   unsafeIndexArrayData (AD_CShort ba) i   = CShort $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CShort ba)          = storableArrayPtr ba-  newArrayData size                       = liftM AD_CShort $ unsafeNewArray_ (0,size-1)+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CShort ba)          = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CShort ba)           = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CShort <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}   unsafeReadArrayData (AD_CShort ba) i    = CShort <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CShort ba) i (CShort e)     = unsafeWriteArray ba i e-  arrayElt                                = ArrayEltRcshort  instance ArrayElt CUShort where   type ArrayPtrs CUShort = Ptr Word16-  unsafeIndexArrayData (AD_CUShort ba) i   = CUShort $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CUShort ba)          = storableArrayPtr ba-  newArrayData size                        = liftM AD_CUShort $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_CUShort ba) i    = CUShort <$> unsafeReadArray ba i+  arrayElt               = ArrayEltRcushort+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_CUShort ba) i  = CUShort $ unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CUShort ba)         = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CUShort ba)          = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CUShort <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_CUShort ba) i   = CUShort <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CUShort ba) i (CUShort e)     = unsafeWriteArray ba i e-  arrayElt                                 = ArrayEltRcushort  instance ArrayElt CInt where   type ArrayPtrs CInt = Ptr Int32-  unsafeIndexArrayData (AD_CInt ba) i   = CInt $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CInt ba)          = storableArrayPtr ba-  newArrayData size                     = liftM AD_CInt $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_CInt ba) i    = CInt <$> unsafeReadArray ba i+  arrayElt            = ArrayEltRcint+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_CInt ba) i     = CInt $ unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CInt ba)            = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CInt ba)             = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CInt <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_CInt ba) i      = CInt <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CInt ba) i (CInt e)     = unsafeWriteArray ba i e-  arrayElt                              = ArrayEltRcint  instance ArrayElt CUInt where   type ArrayPtrs CUInt = Ptr Word32-  unsafeIndexArrayData (AD_CUInt ba) i   = CUInt $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CUInt ba)          = storableArrayPtr ba-  newArrayData size                      = liftM AD_CUInt $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_CUInt ba) i    = CUInt <$> unsafeReadArray ba i+  arrayElt             = ArrayEltRcuint+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_CUInt ba) i    = CUInt $ unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CUInt ba)           = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CUInt ba)            = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CUInt <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_CUInt ba) i     = CUInt <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CUInt ba) i (CUInt e)     = unsafeWriteArray ba i e-  arrayElt                               = ArrayEltRcuint  instance ArrayElt CLong where   type ArrayPtrs CLong = Ptr HTYPE_LONG-  unsafeIndexArrayData (AD_CLong ba) i   = CLong $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CLong ba)          = storableArrayPtr ba-  newArrayData size                      = liftM AD_CLong $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_CLong ba) i    = CLong <$> unsafeReadArray ba i+  arrayElt             = ArrayEltRclong+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_CLong ba) i    = CLong $ unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CLong ba)           = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CLong ba)            = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CLong <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_CLong ba) i     = CLong <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CLong ba) i (CLong e)     = unsafeWriteArray ba i e-  arrayElt                               = ArrayEltRclong  instance ArrayElt CULong where   type ArrayPtrs CULong = Ptr HTYPE_UNSIGNED_LONG+  arrayElt              = ArrayEltRculong+  {-# INLINE unsafeIndexArrayData #-}   unsafeIndexArrayData (AD_CULong ba) i   = CULong $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CULong ba)          = storableArrayPtr ba-  newArrayData size                       = liftM AD_CULong $ unsafeNewArray_ (0,size-1)+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CULong ba)          = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CULong ba)           = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CULong <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}   unsafeReadArrayData (AD_CULong ba) i    = CULong <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CULong ba) i (CULong e)     = unsafeWriteArray ba i e-  arrayElt                                = ArrayEltRculong  instance ArrayElt CLLong where   type ArrayPtrs CLLong = Ptr Int64+  arrayElt              = ArrayEltRcllong+  {-# INLINE unsafeIndexArrayData #-}   unsafeIndexArrayData (AD_CLLong ba) i   = CLLong $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CLLong ba)          = storableArrayPtr ba-  newArrayData size                       = liftM AD_CLLong $ unsafeNewArray_ (0,size-1)+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CLLong ba)          = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CLLong ba)           = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CLLong <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}   unsafeReadArrayData (AD_CLLong ba) i    = CLLong <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CLLong ba) i (CLLong e)     = unsafeWriteArray ba i e-  arrayElt                                = ArrayEltRcllong  instance ArrayElt CULLong where   type ArrayPtrs CULLong = Ptr Word64-  unsafeIndexArrayData (AD_CULLong ba) i   = CULLong $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CULLong ba)          = storableArrayPtr ba-  newArrayData size                        = liftM AD_CULLong $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_CULLong ba) i    = CULLong <$> unsafeReadArray ba i+  arrayElt               = ArrayEltRcullong+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_CULLong ba) i  = CULLong $ unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CULLong ba)         = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CULLong ba)          = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CULLong <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_CULLong ba) i   = CULLong <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CULLong ba) i (CULLong e)     = unsafeWriteArray ba i e-  arrayElt                                 = ArrayEltRcullong  instance ArrayElt Float where   type ArrayPtrs Float = Ptr Float-  unsafeIndexArrayData (AD_Float ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Float ba)          = storableArrayPtr ba-  newArrayData size                      = liftM AD_Float $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_Float ba) i    = unsafeReadArray ba i-  unsafeWriteArrayData (AD_Float ba) i e = unsafeWriteArray ba i e-  arrayElt                               = ArrayEltRfloat+  arrayElt             = ArrayEltRfloat+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_Float ba) i    = unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Float ba)           = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Float ba)            = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Float <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_Float ba) i     = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}+  unsafeWriteArrayData (AD_Float ba) i e  = unsafeWriteArray ba i e  instance ArrayElt Double where   type ArrayPtrs Double = Ptr Double+  arrayElt              = ArrayEltRdouble+  {-# INLINE unsafeIndexArrayData #-}   unsafeIndexArrayData (AD_Double ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Double ba)          = storableArrayPtr ba-  newArrayData size                       = liftM AD_Double $ unsafeNewArray_ (0,size-1)+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Double ba)          = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Double ba)           = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Double <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}   unsafeReadArrayData (AD_Double ba) i    = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_Double ba) i e = unsafeWriteArray ba i e-  arrayElt                                = ArrayEltRdouble  instance ArrayElt CFloat where   type ArrayPtrs CFloat = Ptr Float+  arrayElt              = ArrayEltRcfloat+  {-# INLINE unsafeIndexArrayData #-}   unsafeIndexArrayData (AD_CFloat ba) i   = CFloat $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CFloat ba)          = storableArrayPtr ba-  newArrayData size                       = liftM AD_CFloat $ unsafeNewArray_ (0,size-1)+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CFloat ba)          = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CFloat ba)           = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CFloat <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}   unsafeReadArrayData (AD_CFloat ba) i    = CFloat <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CFloat ba) i (CFloat e)     = unsafeWriteArray ba i e-  arrayElt                                = ArrayEltRcfloat  instance ArrayElt CDouble where   type ArrayPtrs CDouble = Ptr Double-  unsafeIndexArrayData (AD_CDouble ba) i   = CDouble $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CDouble ba)          = storableArrayPtr ba-  newArrayData size                        = liftM AD_CDouble $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_CDouble ba) i    = CDouble <$> unsafeReadArray ba i+  arrayElt               = ArrayEltRcdouble+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_CDouble ba) i  = CDouble $ unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CDouble ba)         = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CDouble ba)          = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CDouble <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_CDouble ba) i   = CDouble <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CDouble ba) i (CDouble e)     = unsafeWriteArray ba i e-  arrayElt                                 = ArrayEltRcdouble  -- Bool arrays are stored as arrays of bytes. While this is memory inefficient,--- it is better suited to parallel backends than the native Unboxed Bool--- array representation that uses packed bit vectors, as that would require--- atomic operations when writing data necessarily serialising threads.+-- it is better suited to parallel backends than a packed bit-vector+-- representation. -- instance ArrayElt Bool where   type ArrayPtrs Bool = Ptr Word8-  unsafeIndexArrayData (AD_Bool ba) i   = toBool (unsafeIndexArray ba i)-  ptrsOfArrayData (AD_Bool ba)          = storableArrayPtr ba-  newArrayData size                     = liftM AD_Bool $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_Bool ba) i    = liftM toBool  $ unsafeReadArray ba i-  unsafeWriteArrayData (AD_Bool ba) i e = unsafeWriteArray ba i (fromBool e)-  arrayElt                              = ArrayEltRbool--{-# INLINE toBool #-}-toBool :: Word8 -> Bool-toBool 0 = False-toBool _ = True--{-# INLINE fromBool #-}-fromBool :: Bool -> Word8-fromBool True  = 1-fromBool False = 0-+  arrayElt            = ArrayEltRbool+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_Bool ba) i     = toBool (unsafeIndexArray ba i)+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Bool ba)            = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Bool ba)             = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Bool <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_Bool ba) i      = toBool  <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}+  unsafeWriteArrayData (AD_Bool ba) i e   = unsafeWriteArray ba i (fromBool e)  -- Unboxed Char is stored as a wide character, which is 4-bytes -- instance ArrayElt Char where   type ArrayPtrs Char = Ptr Char-  unsafeIndexArrayData (AD_Char ba) i   = unsafeIndexArray ba i-  ptrsOfArrayData (AD_Char ba)          = storableArrayPtr ba-  newArrayData size                     = liftM AD_Char $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_Char ba) i    = unsafeReadArray ba i-  unsafeWriteArrayData (AD_Char ba) i e = unsafeWriteArray ba i e-  arrayElt                              = ArrayEltRchar+  arrayElt            = ArrayEltRchar+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_Char ba) i     = unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Char ba)            = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Char ba)             = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_Char <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_Char ba) i      = unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}+  unsafeWriteArrayData (AD_Char ba) i e   = unsafeWriteArray ba i e  instance ArrayElt CChar where   type ArrayPtrs CChar = Ptr HTYPE_CCHAR-  unsafeIndexArrayData (AD_CChar ba) i   = CChar $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CChar ba)          = storableArrayPtr ba-  newArrayData size                      = liftM AD_CChar $ unsafeNewArray_ (0,size-1)-  unsafeReadArrayData (AD_CChar ba) i    = CChar <$> unsafeReadArray ba i+  arrayElt             = ArrayEltRcchar+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_CChar ba) i    = CChar $ unsafeIndexArray ba i+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CChar ba)           = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CChar ba)            = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CChar <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData (AD_CChar ba) i     = CChar <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CChar ba) i (CChar e)     = unsafeWriteArray ba i e-  arrayElt                               = ArrayEltRcchar  instance ArrayElt CSChar where   type ArrayPtrs CSChar = Ptr Int8+  arrayElt              = ArrayEltRcschar+  {-# INLINE unsafeIndexArrayData #-}   unsafeIndexArrayData (AD_CSChar ba) i   = CSChar $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CSChar ba)          = storableArrayPtr ba-  newArrayData size                       = liftM AD_CSChar $ unsafeNewArray_ (0,size-1)+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CSChar ba)          = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CSChar ba)           = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CSChar <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}   unsafeReadArrayData (AD_CSChar ba) i    = CSChar <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CSChar ba) i (CSChar e)     = unsafeWriteArray ba i e-  arrayElt                                = ArrayEltRcschar  instance ArrayElt CUChar where   type ArrayPtrs CUChar = Ptr Word8+  arrayElt              = ArrayEltRcuchar+  {-# INLINE unsafeIndexArrayData #-}   unsafeIndexArrayData (AD_CUChar ba) i   = CUChar $ unsafeIndexArray ba i-  ptrsOfArrayData (AD_CUChar ba)          = storableArrayPtr ba-  newArrayData size                       = liftM AD_CUChar $ unsafeNewArray_ (0,size-1)+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_CUChar ba)          = unsafeUniqueArrayPtr ba+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_CUChar ba)           = touchUniqueArray ba+  {-# INLINE newArrayData #-}+  newArrayData size                       = AD_CUChar <$> newArrayData' size+  {-# INLINE unsafeReadArrayData #-}   unsafeReadArrayData (AD_CUChar ba) i    = CUChar <$> unsafeReadArray ba i+  {-# INLINE unsafeWriteArrayData #-}   unsafeWriteArrayData (AD_CUChar ba) i (CUChar e)     = unsafeWriteArray ba i e-  arrayElt                                = ArrayEltRcuchar  instance (ArrayElt a, ArrayElt b) => ArrayElt (a, b) where-  type ArrayPtrs (a, b)                = (ArrayPtrs a, ArrayPtrs b)-  unsafeIndexArrayData (AD_Pair a b) i = (unsafeIndexArrayData a i, unsafeIndexArrayData b i)-  ptrsOfArrayData (AD_Pair a b)        = (ptrsOfArrayData a, ptrsOfArrayData b)-  newArrayData size-    = do-        a <- newArrayData size-        b <- newArrayData size-        return $ AD_Pair a b-  unsafeReadArrayData (AD_Pair a b) i-    = do-        x <- unsafeReadArrayData a i-        y <- unsafeReadArrayData b i-        return (x, y)-  unsafeWriteArrayData (AD_Pair a b) i (x, y)-    = do-        unsafeWriteArrayData a i x-        unsafeWriteArrayData b i y-  unsafeFreezeArrayData (AD_Pair a b)-    = do-        a' <- unsafeFreezeArrayData a-        b' <- unsafeFreezeArrayData b-        return $ AD_Pair a' b'-  ptrsOfMutableArrayData (AD_Pair a b)-    = do-        aptr <- ptrsOfMutableArrayData a-        bptr <- ptrsOfMutableArrayData b-        return (aptr, bptr)-  arrayElt = ArrayEltRpair arrayElt arrayElt+  type ArrayPtrs (a, b) = (ArrayPtrs a, ArrayPtrs b)+  arrayElt              = ArrayEltRpair arrayElt arrayElt+  {-# INLINE unsafeIndexArrayData #-}+  unsafeIndexArrayData (AD_Pair a b) i        = (unsafeIndexArrayData a i, unsafeIndexArrayData b i)+  {-# INLINE ptrsOfArrayData #-}+  ptrsOfArrayData (AD_Pair a b)               = (ptrsOfArrayData a, ptrsOfArrayData b)+  {-# INLINE touchArrayData #-}+  touchArrayData (AD_Pair a b)                = touchArrayData a >> touchArrayData b+  {-# INLINE unsafeWriteArrayData #-}+  unsafeWriteArrayData (AD_Pair a b) i (x, y) = unsafeWriteArrayData a i x >> unsafeWriteArrayData b i y+  {-# INLINE newArrayData #-}+  newArrayData size                           = AD_Pair <$> newArrayData size <*> newArrayData size+  {-# INLINE unsafeFreezeArrayData #-}+  unsafeFreezeArrayData (AD_Pair a b)         = AD_Pair <$> unsafeFreezeArrayData a <*> unsafeFreezeArrayData b+  {-# INLINE unsafeReadArrayData #-}+  unsafeReadArrayData  (AD_Pair a b) i        = (,) <$> unsafeReadArrayData a i <*> unsafeReadArrayData b i+  {-# INLINE ptrsOfMutableArrayData #-}+  ptrsOfMutableArrayData (AD_Pair a b)        = (,) <$> ptrsOfMutableArrayData a <*> ptrsOfMutableArrayData b --- |Safe combination of creating and fast freezing of array data.----{-# INLINE runArrayData #-}-runArrayData :: ArrayElt e-             => IO (MutableArrayData e, e) -> (ArrayData e, e)-runArrayData st = unsafePerformIO $ do-                    (mad, r) <- st-                    return (mad, r)  -- Array tuple operations -- ---------------------- +{-# INLINE fstArrayData #-} fstArrayData :: ArrayData (a, b) -> ArrayData a fstArrayData (AD_Pair x _) = x +{-# INLINE sndArrayData #-} sndArrayData :: ArrayData (a, b) -> ArrayData b sndArrayData (AD_Pair _ y) = y +{-# INLINE pairArrayData #-} pairArrayData :: ArrayData a -> ArrayData b -> ArrayData (a, b) pairArrayData = AD_Pair  - -- Auxiliary functions -- ------------------- --- Returns the element of an immutable array at the specified index.+{-# INLINE toBool #-}+toBool :: Word8 -> Bool+toBool 0 = False+toBool _ = True++{-# INLINE fromBool #-}+fromBool :: Bool -> Word8+fromBool True  = 1+fromBool False = 0++-- | Safe combination of creating and fast freezing of array data. ----- This does no bounds checking unless you configured with -funsafe-checks. This--- is usually OK, since the functions that convert from multidimensional to--- linear indexing do bounds checking by default.+{-# INLINE runArrayData #-}+runArrayData+    :: IO (MutableArrayData e, e)+    -> (ArrayData e, e)+runArrayData st = unsafePerformIO $ do+  (mad, r) <- st+  return (mad, r)++-- Returns the element of an immutable array at the specified index. This does+-- no bounds checking. -- {-# INLINE unsafeIndexArray #-}-unsafeIndexArray :: MArray a e IO => a Int e -> Int -> e-unsafeIndexArray a i = unsafePerformIO $ unsafeReadArray a i+unsafeIndexArray :: Storable e => UniqueArray e -> Int -> e+unsafeIndexArray ua i = unsafePerformIO $! unsafeReadArray ua i --- Read an element from a mutable array.------ This does no bounds checking unless you configured with -funsafe-checks. This--- is usually OK, since the functions that convert from multidimensional to--- linear indexing do bounds checking by default.+-- Read an element from a mutable array at the given index. This does no bounds+-- checking. -- {-# INLINE unsafeReadArray #-}-unsafeReadArray :: MArray a e m => a Int e -> Int -> m e-#ifdef ACCELERATE_UNSAFE_CHECKS-unsafeReadArray = MArray.readArray-#else-unsafeReadArray = MArray.unsafeRead-#endif+unsafeReadArray :: Storable e => UniqueArray e -> Int -> IO e+unsafeReadArray ua i =+  withUniqueArrayPtr ua $ \ptr -> peekElemOff ptr i --- Write an element into a mutable array.------ This does no bounds checking unless you configured with -funsafe-checks. This--- is usually OK, since the functions that convert from multidimensional to--- linear indexing do bounds checking by default.+-- Write an element into a mutable array at the given index. This does no bounds+-- checking. -- {-# INLINE unsafeWriteArray #-}-unsafeWriteArray :: MArray a e m => a Int e -> Int -> e -> m ()-#ifdef ACCELERATE_UNSAFE_CHECKS-unsafeWriteArray = MArray.writeArray-#else-unsafeWriteArray = MArray.unsafeWrite-#endif+unsafeWriteArray :: Storable e => UniqueArray e -> Int -> e -> IO ()+unsafeWriteArray ua i e =+  withUniqueArrayPtr ua $ \ptr -> pokeElemOff ptr i e --- Obtains a pointer to the payload of an storable array.+-- Allocate a new array with enough storage to hold the given number of+-- elements. ---{-# INLINE storableArrayPtr #-}-storableArrayPtr :: StorableArray i a -> Ptr a-storableArrayPtr (StorableArray _ _ _ fp) = unsafeForeignPtrToPtr fp+-- The array is uninitialised and, in particular, allocated lazily. The latter+-- is important because it means that for backends that have discrete memory+-- spaces (e.g. GPUs), we will not increase host memory pressure simply to track+-- intermediate arrays that contain meaningful data only on the device.+--+{-# INLINE newArrayData' #-}+newArrayData' :: forall e. Storable e => Int -> IO (UniqueArray e)+newArrayData' size+  = $internalCheck "newArrayData" "size must be >= 0" (size >= 0)+  $ newUniqueArray <=< unsafeInterleaveIO $ do+      let bytes = size * sizeOf (undefined :: e)+      new <- readIORef __mallocForeignPtrBytes+      ptr <- new bytes+      traceIO dump_gc $ printf "gc: allocated new host array (size=%d, ptr=%s)" bytes (show ptr)+      return (castForeignPtr ptr)++-- | Register the given function as the callback to use to allocate new array+-- data on the host containing the specified number of bytes. The returned array+-- must be pinned (with respect to Haskell's GC), so that it can be passed to+-- foreign code.+--+registerForeignPtrAllocator+    :: (Int -> IO (ForeignPtr Word8))+    -> IO ()+registerForeignPtrAllocator new = do+  traceIO dump_gc "registering new array allocator"+  atomicWriteIORef __mallocForeignPtrBytes new++{-# NOINLINE __mallocForeignPtrBytes #-}+__mallocForeignPtrBytes :: IORef (Int -> IO (ForeignPtr Word8))+__mallocForeignPtrBytes = unsafePerformIO $! newIORef mallocPlainForeignPtrBytesAligned++-- | Allocate the given number of bytes with 16-byte alignment. This is+-- essential for SIMD instructions.+--+-- Additionally, we return a plain ForeignPtr, which unlike a regular ForeignPtr+-- created with 'mallocForeignPtr' carries no finalisers. It is an error to try+-- to add a finaliser to the plain ForeignPtr. For our purposes this is fine,+-- since in Accelerate finalisers are handled using Lifetime+--+mallocPlainForeignPtrBytesAligned :: Int -> IO (ForeignPtr a)+mallocPlainForeignPtrBytesAligned (I# size) = IO $ \s ->+  case newAlignedPinnedByteArray# size 16# s of+    (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (PlainPtr mbarr#) #) 

@@ -0,0 +1,283 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}+-- |+-- Module      : Data.Array.Accelerate.Array.Lifted+-- Copyright   : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest+-- License     : BSD3+--+-- Maintainer  : Robert Clifton-Everest <robertce@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Lifted array representation. Vector of arrays represented as segmented+-- vectors.+--++module Data.Array.Accelerate.Array.Lifted (++  Vector'(..), LiftedArray,++  LiftedTupleRepr,++  IsConstrained(..),++  isArraysFlat,++  elements', shapes', empty', length', drop', vec2Vec', fromList', toList'++) where++import Prelude                                                  hiding ( concat )+import Data.Typeable++-- friends+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Array.Sugar+import qualified Data.Array.Accelerate.Array.Representation     as Repr+++-- Lifted arrays+-- ----------------+--+-- We specify a special new type of surface tuple to represent the lifted version of members of the+-- `Arrays' class. We do this in order to convince the type checker that the lifted arrays or tuples+-- of arrays, are still members of the 'Arrays' class.++newtype Vector' a = Vector' (LiftedRepr (ArrRepr a) a)+  deriving Typeable++type family LiftedRepr r a where+  LiftedRepr ()     ()                 = ((),Scalar Int)+  LiftedRepr (Array sh e) (Array sh e) = (((),Segments sh), Vector e)+  LiftedRepr (l,r) a                   = LiftedTupleRepr (TupleRepr a)++type family LiftedTupleRepr t :: *+type instance LiftedTupleRepr () = ()+type instance LiftedTupleRepr (b, a) = (LiftedTupleRepr b, Vector' a)++type LiftedArray sh e = Vector' (Array sh e)++instance Arrays t => IsProduct Arrays (Vector' t) where+  type ProdRepr (Vector' t) = LiftedRepr (ArrRepr t) t+  fromProd _ (Vector' t) = t+  toProd _ = Vector'+  prod _ _ = case flavour (undefined :: t) of+                ArraysFunit  -> ProdRsnoc ProdRunit+                ArraysFarray -> ProdRsnoc (ProdRsnoc ProdRunit)+                ArraysFtuple -> tup $ prod (Proxy :: Proxy Arrays) (undefined :: t)+    where+      tup :: forall a. ProdR Arrays a -> ProdR Arrays (LiftedTupleRepr a)+      tup ProdRunit     = ProdRunit+      tup (ProdRsnoc t) = swiz+        where+          swiz :: forall l r. (a ~ (l,r), Arrays r) => ProdR Arrays (LiftedTupleRepr a)+          swiz | IsC <- isArraysFlat (undefined :: r)+               = ProdRsnoc (tup t)+++type instance ArrRepr (Vector' a) = ArrRepr (TupleRepr (Vector' a))+++instance (Arrays t, Typeable (ArrRepr (Vector' t))) => Arrays (Vector' t) where+  arrays _ = arrs (prod (Proxy :: Proxy Arrays) (undefined :: Vector' t))+    where+      arrs :: forall a. ProdR Arrays a -> ArraysR (ArrRepr a)+      arrs ProdRunit     = ArraysRunit+      arrs (ProdRsnoc t) = ArraysRpair (ArraysRpair ArraysRunit (arrs t)) (arrays t')+        where t' :: (a ~ (l,r)) => r+              t' = undefined+  flavour _ = case flavour (undefined :: t) of+                ArraysFunit  -> ArraysFtuple+                ArraysFarray -> ArraysFtuple+                ArraysFtuple | ProdRsnoc _ <- prod (Proxy :: Proxy Arrays) (undefined::t)+                             -> ArraysFtuple+                             | otherwise -> error "Absurd"+  --+  fromArr (Vector' vt) = fa (prod (Proxy :: Proxy Arrays) (undefined :: Vector' t)) vt+    where+      fa :: forall a. ProdR Arrays a -> a -> ArrRepr a+      fa ProdRunit     ()    = ()+      fa (ProdRsnoc t) (l,a) = (((), fa t l), fromArr a)+  toArr = Vector' . ta (prod (Proxy :: Proxy Arrays) (undefined :: Vector' t))+    where+      ta :: forall a. ProdR Arrays a -> ArrRepr a -> a+      ta ProdRunit     ()         = ()+      ta (ProdRsnoc t) (((),l),a) = (ta t l, toArr a)++data IsConstrained c where+  IsC :: c => IsConstrained c++type IsTypeableArrRepr t = IsConstrained (Typeable (ArrRepr t))++type IsArraysFlat t = IsConstrained (Arrays (Vector' t))++isTypeableArrRepr :: forall t. Arrays t => {- dummy -} t -> IsTypeableArrRepr (Vector' t)+isTypeableArrRepr _ =+  case flavour (undefined :: t) of+    ArraysFunit  -> IsC+    ArraysFarray -> IsC+    ArraysFtuple | IsC <- isT (prod (Proxy :: Proxy Arrays) (undefined :: Vector' t))+                 -> IsC+  where+    isT :: ProdR Arrays t' -> IsTypeableArrRepr t'+    isT ProdRunit                    = IsC+    isT (ProdRsnoc t) | IsC <- isT t = IsC++isArraysFlat :: forall t. Arrays t => {- dummy -} t -> IsArraysFlat t+isArraysFlat t = case flavour t of+                   ArraysFunit  -> IsC+                   ArraysFtuple | IsC <- isTypeableArrRepr t+                                -> IsC+                   ArraysFarray -> IsC+++-- Useful helper-functions (not exported)+-- --------------------------------------++scalar :: Elt a => a -> Scalar a+scalar n = fromList Z [n]++emptyVec :: Elt a => Vector a+emptyVec = fromList (Z :. (0 :: Int)) []++flatten :: Array sh e -> Vector e+flatten (Array sh e) = Array ((), Repr.size sh) e+++-- Useful helper-functions for Vector'+-- ----------------------------------++-- Get all the elements. O(1).+--+elements' :: Vector' (Array sh e) -> Vector e+elements' (Vector' (_, elts)) = elts++-- Get all the shapes. O(1).+--+shapes' :: Vector' (Array sh a) -> Vector sh+shapes' (Vector' (((), shapes), _)) = shapes++-- The empty Vector'. O(1).+empty' :: forall a. Arrays a => Vector' a+empty' = Vector' $+  case flavour (undefined :: a) of+    ArraysFunit  -> ((), scalar 0)+    ArraysFarray -> (((), emptyVec), emptyVec)+    ArraysFtuple -> tup (prod (Proxy :: Proxy Arrays) (undefined :: a))+  where+    tup :: forall t. ProdR Arrays t -> LiftedTupleRepr t+    tup ProdRunit = ()+    tup (ProdRsnoc t) = (tup t, empty')++-- Number of arrays in Vector'. O(1).+--+length' :: forall a. Arrays a => Vector' a -> Int+length' (Vector' x) =+  case flavour (undefined :: a) of+    ArraysFunit  | ((), n) <- x+                 -> n ! Z+    ArraysFarray | (((), Array ((), n) _), _) <- x+                 -> n+    ArraysFtuple -> tup (prod (Proxy :: Proxy Arrays) (undefined :: a)) x+  where+    tup :: forall t. ProdR Arrays t -> LiftedTupleRepr t -> Int+    tup ProdRunit () = error "unreachable"+    tup (ProdRsnoc _) (_, b) = length' b++-- Drop a number of arrays from a Vector'.+--+drop' :: forall a. Arrays a+      -- Implementation specific drop for basic vectors:+      => (forall e. Elt e => Int -> Vector e -> Vector e)+      -- Implementation specific segments-to-offsets:+      -> (forall sh. Shape sh => Segments sh -> Vector Int)+      -> Int -> Vector' a -> Vector' a+drop' dropVec s2o k (Vector' x) = Vector' $+  case flavour (undefined :: a) of+    ArraysFunit |  ((), n                         ) <- x+                -> ((), scalar (n ! Z - k `max` 0))+    ArraysFarray | (((), segs), vals) <- x+                 , Array ((), n) _ <- segs+                 , k < n+                 -> let offsets = s2o segs+                        k' = offsets ! (Z :. k)+                    in (((), dropVec k segs), dropVec k' vals)+    ArraysFarray -> (((), emptyVec), emptyVec)+    ArraysFtuple -> tup (prod (Proxy :: Proxy Arrays) (undefined :: a)) x+  where+    tup :: forall t. ProdR Arrays t -> LiftedTupleRepr t -> LiftedTupleRepr t+    tup ProdRunit () = ()+    tup (ProdRsnoc t) (a, b) = (tup t a, drop' dropVec s2o k b)++-- Convert a vector to a Vector' of scalars.+--+vec2Vec' :: Elt e => Vector e -> Vector' (Scalar e)+vec2Vec' v = Vector' (((), undefined), v) -- TODO undefined Vector of Z's?++toList' :: forall a. Arrays a+        -- Implementation-specific fetchAll:+        => (forall sh e. (Shape sh, Elt e) => Segments sh -> Vector e -> [Array sh e])+        -> Vector' a -> [a]+toList' fetchAll (Vector' x) =+  case flavour (undefined :: a) of+    ArraysFunit | ((), n) <- x -> replicate (n ! Z) ()+    ArraysFarray | (((), lens), vals) <- x+                 -> fetchAll lens vals+    ArraysFtuple -> map (toProd (Proxy :: Proxy Arrays)) (tup (prod (Proxy :: Proxy Arrays) (undefined :: a)) x)+  where+    tup :: forall t. ProdR Arrays t -> LiftedTupleRepr t -> [t]+    tup ProdRunit () = repeat ()+    tup (ProdRsnoc t) (a, b) = tup t a `zip` toList' fetchAll b++fromList' :: forall a. Arrays a+          -- Implementation specific concat+          => (forall e. Elt e => [Vector e] -> Vector e)+          -> [a] -> Vector' a+fromList' concat xs = Vector' $+  case flavour (undefined :: a) of+    ArraysFunit -> ((), scalar (length xs))+    ArraysFarray ->+      let segs = map shape xs+          vals = concat (map flatten xs)+      in (((), fromList (Z :. length segs) segs), vals)+    ArraysFtuple -> tup (prod (Proxy :: Proxy Arrays) (undefined :: a)) (map (fromProd (Proxy :: Proxy Arrays)) xs)+  where+    tup :: forall t. ProdR Arrays t -> [t] -> LiftedTupleRepr t+    tup ProdRunit _     = ()+    tup (ProdRsnoc t) a = (tup t (Prelude.map fst a), fromList' concat (map snd a))++{-+map' :: (Arrays a, Arrays b)+     => (forall e. Elt e => [Vector e] -> Vector e)+     -> (forall sh e. (Shape sh, Elt e) => Segments sh -> Vector e -> [Array sh e])+     -> (a -> b) -> Vector' a -> Vector' b+map' concat fetchAll f x = fromList' concat $ map f (toList' fetchAll x)+-}++{-+helper :: forall a r. Arrays a+       => (Scalar Int -> r ())+       -> (forall sh e. (Shape sh, Elt e) => Segments sh -> Vector e -> r (Array sh e))+       -> r ()+       -> (forall t s. r t -> r s -> r (t, s))+       -> (forall t. r (ProdRepr t) -> r t)+       -> Vector' a -> r a+helper units arr unit pair fix (Vector' x) =+  case flavour (undefined :: a) of+    ArraysFunit | ((), n) <- x -> units n+    ArraysFarray | (((), lens), vals) <- x+                 -> arr lens vals+    ArraysFtuple -> fix $ tup (prod (Proxy :: Proxy Arrays) (undefined :: a)) x+  where+    tup :: forall t. ProdR Arrays t -> LiftedTupleRepr t -> r t+    tup ProdRunit () = unit+    tup (ProdRsnoc t) (x, y) = tup t x `pair` helper units arr unit pair fix y+-}+

@@ -0,0 +1,26 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Array.Remote+-- Copyright   : [2015..2017] Manuel M T Chakravarty, Gabriele Keller, Robert Clifton-Everest+--               [2016..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Robert Clifton-Everest <robertce@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Umbrella module for the remote memory management facilities. To implement an+-- LRU cache for your backend, provide an instance of the 'RemoteMemory' class,+-- and, if required, specialise or overload the LRU functions to your particular+-- memory table types.+--++module Data.Array.Accelerate.Array.Remote (++  module Remote++) where++import Data.Array.Accelerate.Array.Remote.Class         as Remote+import Data.Array.Accelerate.Array.Remote.LRU           as Remote+

@@ -0,0 +1,81 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies    #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Array.Remote.Class+-- Copyright   : [2015..2017] Manuel M T Chakravarty, Gabriele Keller, Robert Clifton-Everest+--               [2016..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Robert Clifton-Everest <robertce@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module define a class of operations over pointers in a remote memory+-- space. Backends provide an instance of this class, and then can use (or+-- extend upon) one of the following modules in order to manage the remote+-- memory:+--+-- * 'Data.Array.Accelerate.Array.Remote.Table': basic, unmanaged memory tables,+--   mapping accelerate arrays on the host to the corresponding array in the+--   remote memory space.+--+-- * 'Data.Array.Accelerate.Array.Remote.LRU': managed memory tables which+--   additionally evict old entries from the device if the remote memory is+--   exhausted.+--++module Data.Array.Accelerate.Array.Remote.Class (++  RemoteMemory(..), PrimElt++) where++import Data.Array.Accelerate.Array.Data++import Control.Applicative+import Control.Monad.Catch+import Data.Int+import Data.Word+import Data.Typeable+import Foreign.Ptr+import Foreign.Storable+import Prelude+++-- | Matches array element types to primitive types.+--+type PrimElt e a = (ArrayElt e, Storable a, ArrayPtrs e ~ Ptr a, Typeable e, Typeable a)++-- | Accelerate backends can provide an instance of this class in order to take+-- advantage of the automated memory managers we provide as part of the base+-- package.+--+class (Applicative m, Monad m, MonadCatch m, MonadMask m) => RemoteMemory m where++  -- | Pointers into this particular remote memory.+  type RemotePtr m :: * -> *++  -- | Attempt to allocate the given number of bytes in the remote memory space.+  -- Returns Nothing on failure.+  mallocRemote :: Int -> m (Maybe (RemotePtr m Word8))++  -- | Copy the given number of elements from the host array into remote memory.+  pokeRemote :: PrimElt e a => Int -> RemotePtr m a -> ArrayData e -> m ()++  -- | Copy the given number of elements from remote memory to the host array.+  peekRemote :: PrimElt e a => Int -> RemotePtr m a -> MutableArrayData e -> m ()++  -- | Cast a remote pointer.+  castRemotePtr :: proxy m -> RemotePtr m a -> RemotePtr m b++  -- | Returns the total remote memory available in bytes.+  totalRemoteMem :: m Int64++  -- | Returns, in bytes, the available remote memory.+  availableRemoteMem :: m Int64++  -- | The chunk allocation size (bytes).+  remoteAllocationSize :: m Int+  remoteAllocationSize = return 1024+

@@ -0,0 +1,399 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE DoAndIfThenElse     #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Array.Remote.Cache+-- Copyright   : [2015..2017] Manuel M T Chakravarty, Gabriele Keller, Robert Clifton-Everest+--               [2016..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Robert Clifton-Everest <robertce@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module extends the memory tables provided by+-- 'Data.Array.Accelerate.Array.Remote.Table' with an LRU caching policy that+-- evicts old arrays from the remote memory space once it runs out of memory.+-- Consequently, use of this module requires the backend client to keep track of+-- which remote arrays are currently being used, so that they will not be+-- evicted. See: 'withRemote' for more details on this requirement.+--+module Data.Array.Accelerate.Array.Remote.LRU (++  -- Tables for host/device memory associations+  MemoryTable, new, withRemote, malloc, free, insertUnmanaged, reclaim,++  -- Asynchronous tasks+  Task(..)++) where++import Data.Functor+import Data.Maybe                                               ( isNothing )+import Data.Proxy+import Control.Monad                                            ( filterM )+import Control.Monad.Catch+import Control.Monad.IO.Class                                   ( MonadIO, liftIO )+import Control.Concurrent.MVar                                  ( MVar, newMVar, takeMVar, putMVar, mkWeakMVar )+import System.CPUTime+import System.Mem.Weak                                          ( Weak, deRefWeak, finalize )+import Prelude                                                  hiding ( lookup )++import qualified Data.HashTable.IO                              as HT++import qualified Data.Array.Accelerate.Debug                    as D+import Data.Array.Accelerate.Error                              ( internalError )+import Data.Array.Accelerate.Array.Data                         ( ArrayData, touchArrayData )+import Data.Array.Accelerate.Array.Remote.Class+import Data.Array.Accelerate.Array.Remote.Table                 ( StableArray, makeWeakArrayData )+import qualified Data.Array.Accelerate.Array.Remote.Table       as Basic+++-- We build cached memory tables on top of a basic memory table.+--+-- A key invariant is that the arrays in the MemoryTable are a subset of the+-- arrays in the UseTable. The UseTable reflects all arrays that have ever been+-- in the cache.+--+data MemoryTable p task = MemoryTable {-# UNPACK #-} !(Basic.MemoryTable p)+                                      {-# UNPACK #-} !(UseTable task)+                                      {-# UNPACK #-} !(Weak (UseTable task))++type UT task            = HT.BasicHashTable StableArray (Used task)+type UseTable task      = MVar (UT task)++data Status = Clean     -- Array in remote memory matches array in host memory.+            | Dirty     -- Array in remote memory has been modified.+            | Unmanaged -- Array in remote memory was injected by FFI, so we+                        -- cannot remove it under any circumstance.+            | Evicted   -- Array has been evicted from remote memory+            deriving Eq++type Timestamp = Integer++data Used task where+  Used :: PrimElt e a+       => !Timestamp+       -> !Status+       -> {-# UNPACK #-} !Int                   -- Use count+       -> ![task]                               -- Asynchronous tasks using the array+       -> {-# UNPACK #-} !Int                   -- Array size+       -> {-# UNPACK #-} !(Weak (ArrayData e))+       -> Used task++-- |A Task represents a process executing asynchronously that can be polled for+-- its status. This is necessary for backends that work asynchronously (i.e.+-- the CUDA backend). If a backend is synchronous, the () instance can be used.+--+class Task task where+  -- |Returns true when the task has finished.+  completed :: task -> IO Bool++instance Task () where+  completed () = return True++-- |Create a new memory cache from host to remote arrays.+--+-- The function supplied should be the `free` for the remote pointers being+-- stored. This function will be called by the GC, which typically runs on a+-- different thread. Unlike the `free` in `RemoteMemory`, this function cannot+-- depend on any state.+--+new :: (forall a. ptr a -> IO ()) -> IO (MemoryTable ptr task)+new release = do+  mt        <- Basic.new release+  utbl      <- HT.new+  ref       <- newMVar utbl+  weak_utbl <- mkWeakMVar ref (cache_finalizer utbl)+  return    $! MemoryTable mt ref weak_utbl++-- |Perform some action that requires the remote pointer corresponding to+-- the given array. Returns `Nothing` if the array have NEVER been in the+-- cache. If the array was previously in the cache, but was evicted due to its+-- age, then the array will be copied back from host memory.+--+-- The continuation passed as the third argument needs to obey some precise+-- properties. As with all bracketed functions, the supplied remote pointer must+-- not leak out of the function, as it is only guaranteed to be valid within it.+-- If it is required that it does leak (e.g. the backend is uses concurrency to+-- interleave execution of different parts of the program), then `completed` on+-- the returned task should not return true until it is guaranteed there are no+-- more accesses of the remote pointer.+--+withRemote+    :: forall task m a b c. (PrimElt a b, Task task, RemoteMemory m, MonadIO m, Functor m)+    => MemoryTable (RemotePtr m) task+    -> ArrayData a+    -> (RemotePtr m b -> m (task, c))+    -> m (Maybe c)+withRemote (MemoryTable !mt !ref _) !arr run = do+  key <- Basic.makeStableArray arr+  mp  <- withMVar' ref $ \utbl -> do+    mu <- liftIO $ HT.lookup utbl key+    case mu of+      Nothing -> do message ("withRemote/array has never been malloc'd: " ++ show key)+                    return Nothing+      Just u  -> do+        mp <- liftIO $ do HT.insert utbl key (incCount u)+                          Basic.lookup mt arr+        case mp of+          Nothing | isEvicted u -> Just <$> copy utbl (incCount u)+          Just p                -> return (Just p)+          _                     -> do message ("lost array " ++ show key)+                                      $internalError "withRemote" "non-evicted array has been lost"+  --+  case mp of+    Just p  -> Just <$> run' p+    Nothing -> return Nothing -- The array was never in the table.+  where+    updateTask :: Maybe (Used task) -> task -> IO (Used task)+    updateTask mu task = do+      ts  <- getCPUTime+      case mu of+        Nothing -> $internalError "withRemote" "Invariant violated"+        Just (Used _ status count tasks n weak_arr) -> do+          tasks'  <- cleanUses tasks+          return (Used ts status (count - 1) (task : tasks') n weak_arr)++    copy :: UT task -> Used task -> m (RemotePtr m b)+    copy utbl (Used ts _ count tasks n weak_arr) = do+      message "withRemote/reuploading-evicted-array"+      p <- mallocWithUsage mt utbl arr (Used ts Clean count tasks n weak_arr)+      pokeRemote n p arr+      return p++    run' :: RemotePtr m b -> m c+    run' p = do+      key <- Basic.makeStableArray arr+      message ("withRemote/using: " ++ show key)+      (task, c) <- run p+      withMVar' ref $ \utbl -> liftIO $ do+        mu       <- HT.lookup utbl key+        u        <- updateTask mu task+        HT.insert utbl key u+      liftIO $ touchArrayData arr+      return c+++-- | Allocate a new device array to be associated with the given host-side array.+-- This has similar behaviour to malloc in Data.Array.Accelerate.Array.Memory.Table+-- but also will copy remote arrays back to main memory in order to make space.+--+-- The third argument indicates that the array should be considered frozen.+-- That is to say the array arrays contents will never change. In the event that+-- the array has to be evicted from the remote memory, the copy already residing+-- in host memory should be considered valid.+--+-- If malloc is called on an array that is already contained within the cache,+-- it becomes a no-op.+--+-- On return, 'True' indicates that we allocated some remote memory, and 'False'+-- indicates that we did not need to.+--+malloc :: forall a e m task. (PrimElt e a, RemoteMemory m, MonadIO m, Task task)+       => MemoryTable (RemotePtr m) task+       -> ArrayData e+       -> Bool                               -- ^True if host array is frozen.+       -> Int+       -> m Bool+malloc (MemoryTable mt ref weak_utbl) !ad !frozen !n = do+  ts  <- liftIO $ getCPUTime+  key <- Basic.makeStableArray ad+  --+  let status = if frozen+                 then Clean+                 else Dirty+  --+  withMVar' ref $ \utbl -> do+    mu <- liftIO $ HT.lookup utbl key+    if isNothing mu+      then do+        weak_arr <- liftIO $ makeWeakArrayData ad ad (Just $ finalizer key weak_utbl)+        _        <- mallocWithUsage mt utbl ad (Used ts status 0 [] n weak_arr)+        return True+      else+        return False++mallocWithUsage+    :: forall a e m task. (PrimElt e a, RemoteMemory m, MonadIO m, Task task)+    => Basic.MemoryTable (RemotePtr m)+    -> UT task+    -> ArrayData e+    -> Used task+    -> m (RemotePtr m a)+mallocWithUsage !mt utbl !ad !usage@(Used _ _ _ _ n _) = malloc'+  where+    malloc' = do+      mp <- Basic.malloc mt ad n :: m (Maybe (RemotePtr m a))+      case mp of+        Nothing -> do+          success <- evictLRU utbl mt+          if success then malloc' else $internalError "malloc" "Remote memory exhausted"+        Just p -> liftIO $ do+          key <- Basic.makeStableArray ad+          HT.insert utbl key usage+          return p++evictLRU :: forall m task. (RemoteMemory m, MonadIO m, Task task)+         => UT task+         -> Basic.MemoryTable (RemotePtr m)+         -> m Bool+evictLRU utbl mt = trace "evictLRU/evicting-eldest-array" $  do+  mused <- liftIO $ HT.foldM eldest Nothing utbl+  case mused of+    Just (sa, Used ts status count tasks n weak_arr) -> do+      mad <- liftIO $ deRefWeak weak_arr+      case mad of+        Nothing -> liftIO $ do+          -- This can only happen if our eviction process was interrupted by+          -- garbage collection. In which case, even though we didn't actually+          -- evict anything, we should return true, as we know some remote+          -- memory is now free.+          --+          -- Small caveat: Due to finalisers being delayed, it's a good idea+          -- to free the array here.+          Basic.freeStable (Proxy :: Proxy m) mt sa+          delete utbl sa+          message "evictLRU/Accelerate GC interrupted by GHC GC"+        Just arr -> do+          message ("evictLRU/evicting " ++ show sa)+          copyIfNecessary status n arr+          liftIO $ Basic.freeStable (Proxy :: Proxy m) mt sa+          liftIO $ HT.insert utbl sa (Used ts Evicted count tasks n weak_arr)+      return True+    _ -> trace "evictLRU/All arrays in use, unable to evict" $ return False+  where+    -- Find the eldest, not currently in use, array.+    eldest :: (Maybe (StableArray, Used task)) -> (StableArray, Used task) -> IO (Maybe (StableArray, Used task))+    eldest prev (sa, used@(Used ts status count tasks n weak_arr)) | count == 0+                                                                   , evictable status = do+      tasks' <- cleanUses tasks+      HT.insert utbl sa (Used ts status count tasks' n weak_arr)+      case tasks' of+        [] | Just (_, Used ts' _ _ _ _ _) <- prev+           , ts < ts'        -> return (Just (sa, used))+           | Nothing <- prev -> return (Just (sa, used))+        _  -> return prev+    eldest prev _ = return prev++    evictable :: Status -> Bool+    evictable Clean     = True+    evictable Dirty     = True+    evictable Unmanaged = False+    evictable Evicted   = False++    copyIfNecessary :: PrimElt e a => Status -> Int -> ArrayData e -> m ()+    copyIfNecessary Clean     _ _  = return ()+    copyIfNecessary Unmanaged _ _  = return ()+    copyIfNecessary Evicted   _ _  = $internalError "evictLRU" "Attempting to evict already evicted array"+    copyIfNecessary Dirty     n ad = do+      mp <- liftIO $ Basic.lookup mt ad+      case mp of+        Nothing -> return () -- RCE: I think this branch is actually impossible.+        Just p  -> peekRemote n p ad++-- | Deallocate the device array associated with the given host-side array.+-- Typically this should only be called in very specific circumstances. This+-- operation is not thread-safe.+--+free :: (RemoteMemory m, PrimElt a b)+     => proxy m+     -> MemoryTable (RemotePtr m) task+     -> ArrayData a+     -> IO ()+free proxy (MemoryTable !mt !ref _) !arr = withMVar' ref $ \utbl -> do+  key <- Basic.makeStableArray arr+  delete utbl key+  Basic.freeStable proxy mt key++-- |Record an association between a host-side array and a remote memory area+-- that was not allocated by accelerate. The remote memory will NOT be re-used+-- once the host-side array is garbage collected.+--+-- This typically only has use for backends that provide an FFI.+--+insertUnmanaged+    :: (PrimElt e a, MonadIO m)+    => MemoryTable p task+    -> ArrayData e+    -> p a+    -> m ()+insertUnmanaged (MemoryTable mt ref weak_utbl) !arr !ptr = liftIO . withMVar' ref $ \utbl -> do+  key <- Basic.makeStableArray arr+  Basic.insertUnmanaged mt arr ptr+  ts <- getCPUTime+  weak_arr <- makeWeakArrayData arr arr (Just $ finalizer key weak_utbl)+  HT.insert utbl key (Used ts Unmanaged 0 [] 0 weak_arr)+++-- Removing entries+-- ----------------++finalizer :: StableArray -> Weak (UseTable task) -> IO ()+finalizer !key !weak_utbl = do+  mref <- deRefWeak weak_utbl+  case mref of+    Nothing  -> message "finalize cache/dead table"+    Just ref -> trace  ("finalize cache: " ++ show key) $ withMVar' ref (`delete` key)++delete :: UT task -> StableArray -> IO ()+delete utbl key = do+  mu <- HT.lookup utbl key+  case mu of+    Nothing -> return ()+    Just _  -> HT.delete utbl key++-- |Initiate garbage collection and `free` any remote arrays that no longer+-- have matching host-side equivalents.+--+reclaim+    :: forall m task. (RemoteMemory m, MonadIO m)+    => MemoryTable (RemotePtr m) task+    -> m ()+reclaim (MemoryTable !mt _ _) = Basic.reclaim mt++cache_finalizer :: UT task -> IO ()+cache_finalizer !tbl+  = trace "cache finaliser"+  $ HT.mapM_ (\(_,u) -> f u)+             tbl+  where+    f :: Used task -> IO ()+    f (Used _ _ _ _ _ w) = finalize w++-- Miscellaneous+-- -------------++cleanUses :: Task task => [task] -> IO [task]+cleanUses = filterM (fmap not . completed)++incCount :: Used task -> Used task+incCount (Used ts status count uses n weak_arr) = Used ts status (count + 1) uses n weak_arr++isEvicted :: Used task -> Bool+isEvicted (Used _ status _ _ _ _) = status == Evicted++withMVar' :: (MonadIO m, MonadMask m) => MVar a -> (a -> m b) -> m b+withMVar' m f = mask $ \restore -> do+  a <- liftIO $ takeMVar m+  b <- restore (f a) `onException` (liftIO $ putMVar m a)+  liftIO $ putMVar m a+  return b++-- Debug+-- -----++{-# INLINE trace #-}+trace :: MonadIO m => String -> m a -> m a+trace msg next = message msg >> next++{-# INLINE message #-}+message :: MonadIO m => String -> m ()+message msg = liftIO $ D.traceIO D.dump_gc ("gc: " ++ msg)+

@@ -0,0 +1,122 @@+{-# LANGUAGE BangPatterns    #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Module      : Data.Array.Accelerate.Array.Remote.Nursery+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+--               [2015..2017] Robert Clifton-Everest+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Array.Remote.Nursery (++  Nursery(..), NRS, new, lookup, insert, cleanup, size++) where++-- friends+import Data.Array.Accelerate.Error+import qualified Data.Array.Accelerate.Debug                    as D++-- libraries+import Prelude                                                  hiding ( lookup )+import Control.Concurrent.MVar+import Data.Int+import Data.IntMap                                              ( IntMap )+import Data.Sequence                                            ( Seq )+import Data.Word+import System.Mem.Weak                                          ( Weak )+import qualified Data.IntMap.Strict                             as IM+import qualified Data.Sequence                                  as Seq+import qualified Data.Traversable                               as Seq+++-- The nursery is a place to store remote memory arrays that are no longer+-- needed. Often it is quicker to reuse an existing array, rather than call out+-- to the external API to allocate fresh memory.+--+-- The nursery is wrapped in an MVar so that several threads may safely access+-- it concurrently.+--+data Nursery ptr        = Nursery {-# UNPACK #-} !(NRS ptr)+                                  {-# UNPACK #-} !(Weak (NRS ptr))+type NRS ptr            = MVar (N ptr)++data N ptr              = N !(IntMap (Seq (ptr Word8)))       -- #bytes -> ptr+                            {-# UNPACK #-} !Int64             -- total allocated bytes+++-- | Create a fresh nursery.+--+-- When the nursery is garbage collected, the provided function will be run on+-- each value to free the retained memory.+--+{-# INLINEABLE new #-}+new :: (ptr Word8 -> IO ()) -> IO (Nursery ptr)+new delete = do+  message "initialise nursery"+  ref    <- newMVar ( N IM.empty 0 )+  weak   <- mkWeakMVar ref (cleanup delete ref)+  return $! Nursery ref weak+++-- | Look for an entry with the requested size.+--+{-# INLINEABLE lookup #-}+lookup :: Int -> Nursery ptr -> IO (Maybe (ptr Word8))+lookup !key (Nursery !ref !_) =+  modifyMVar ref $ \nrs@( N im sz ) ->+    let+        (mv, nrs')  = IM.updateLookupWithKey f key im         -- returns _original_ value, if located+        f _k v      =+          case Seq.viewl v of+            Seq.EmptyL  -> $internalError "lookup" "expected non-empty sequence"+            _ Seq.:< vs -> if Seq.null vs then Nothing        -- delete this entry in the map+                                          else Just vs        -- re-insert the tail+    in+    case fmap Seq.viewl mv of+      Just (v Seq.:< _) -> return ( N nrs' (sz - fromIntegral key) , Just v  )+      _                 -> return ( nrs,                             Nothing )+++-- | Add an entry to the nursery+--+{-# INLINEABLE insert #-}+insert :: Int -> ptr Word8 -> Nursery ptr -> IO ()+insert !key !val (Nursery !ref _) =+  let+      f Nothing   = Just (Seq.singleton val)+      f (Just vs) = Just (vs Seq.|> val)+  in+  modifyMVar_ ref $ \(N im sz) ->+    return $! N (IM.alter f key im) (sz + fromIntegral key)+++-- | Delete all entries from the nursery+--+{-# INLINEABLE cleanup #-}+cleanup :: (ptr Word8 -> IO ()) -> NRS ptr -> IO ()+cleanup delete !ref = do+  message "nursery cleanup"+  modifyMVar_ ref $ \(N nrs _) -> do mapM_ (Seq.mapM delete) (IM.elems nrs)+                                     return ( N IM.empty 0 )+++-- | The total number of bytes retained by the nursery+--+{-# INLINEABLE size #-}+size :: Nursery ptr -> IO Int64+size (Nursery ref _) = withMVar ref $ \(N _ sz) -> return sz+++-- Debug+-- -----++{-# INLINE message #-}+message :: String -> IO ()+message msg = D.traceIO D.dump_gc ("gc: " ++ msg)+

@@ -0,0 +1,466 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE PatternGuards              #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE ViewPatterns               #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Array.Remote.Table+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+--               [2015..2017] Robert Clifton-Everest+-- License     : BSD3+--+-- Maintainer  : Robert Clifton-Everest <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Accelerate backends often need to copy arrays to a remote memory before they+-- can be used in computation. This module provides an automated method for+-- doing so. Keeping track of arrays in a `MemoryTable` ensures that any memory+-- allocated for them will be freed when GHC's garbage collector collects the+-- host array.+--+module Data.Array.Accelerate.Array.Remote.Table (++  -- Tables for host/device memory associations+  MemoryTable, new, lookup, malloc, free, freeStable, insertUnmanaged, reclaim,++  -- Internals+  StableArray, makeStableArray,+  makeWeakArrayData++) where++import Control.Concurrent                                       ( yield )+import Control.Concurrent.MVar                                  ( MVar, newMVar, withMVar, mkWeakMVar )+import Control.Concurrent.Unique                                ( Unique )+import Control.Monad.IO.Class                                   ( MonadIO, liftIO )+import Data.Functor+import Data.Hashable                                            ( hash, Hashable )+import Data.Maybe                                               ( isJust )+import Data.Proxy+import Data.Typeable                                            ( Typeable, gcast )+import Data.Word+import Foreign.Storable                                         ( sizeOf )+import System.Mem                                               ( performGC )+import System.Mem.Weak                                          ( Weak, deRefWeak )+import Prelude                                                  hiding ( lookup, id )+import qualified Data.HashTable.IO                              as HT++import GHC.Exts                                                 ( Ptr(..) )++import Data.Array.Accelerate.Error                              ( internalError )+import Data.Array.Accelerate.Array.Unique                       ( UniqueArray(..) )+import Data.Array.Accelerate.Array.Data                         ( ArrayData, GArrayData(..),+                                                                  ArrayPtrs, ArrayElt, arrayElt, ArrayEltR(..) )+import Data.Array.Accelerate.Array.Remote.Class+import Data.Array.Accelerate.Array.Remote.Nursery               ( Nursery(..) )+import Data.Array.Accelerate.Lifetime+import qualified Data.Array.Accelerate.Array.Remote.Nursery     as N+import qualified Data.Array.Accelerate.Debug                    as D+++-- We use an MVar to the hash table, so that several threads may safely access+-- it concurrently. This includes the finalisation threads that remove entries+-- from the table.+--+-- It is important that we can garbage collect old entries from the table when+-- the key is no longer reachable in the heap. Hence the value part of each+-- table entry is a (Weak val), where the stable name 'key' is the key for the+-- memo table, and the 'val' is the value of this table entry. When the key+-- becomes unreachable, a finaliser will fire and remove this entry from the+-- hash buckets, and further attempts to dereference the weak pointer will+-- return Nothing. References from 'val' to the key are ignored (see the+-- semantics of weak pointers in the documentation).+--+type HashTable key val  = HT.BasicHashTable key val+type MT p               = MVar ( HashTable StableArray (RemoteArray p) )+data MemoryTable p      = MemoryTable {-# UNPACK #-} !(MT p)+                                      {-# UNPACK #-} !(Weak (MT p))+                                      {-# UNPACK #-} !(Nursery p)+                                      (p Word8 -> IO ())++data RemoteArray p where+  RemoteArray :: Typeable e+              => {-# UNPACK #-} !(Weak ())  -- Keep track of host array liveness+              -> !(p e)                     -- The actual remote pointer+              -> {-# UNPACK #-} !Int        -- The array size in bytes+              -> RemoteArray p++-- | An untyped reference to an array, similar to a StableName.+--+newtype StableArray = StableArray Unique+  deriving (Eq, Hashable)++instance Show StableArray where+  show (StableArray u) = show (hash u)++-- |Create a new memory table from host to remote arrays.+--+-- The function supplied should be the `free` for the remote pointers being+-- stored. This function will be called by the GC, which typically runs on a+-- different thread. Unlike the `free` in `RemoteMemory`, this function cannot+-- depend on any state.+--+new :: (forall a. ptr a -> IO ()) -> IO (MemoryTable ptr)+new release = do+  message "initialise memory table"+  tbl  <- HT.new+  ref  <- newMVar tbl+  nrs  <- N.new release+  weak <- mkWeakMVar ref (return ())+  return $! MemoryTable ref weak nrs release+++-- | Look for the remote pointer corresponding to a given host-side array.+--+lookup+    :: (PrimElt a b)+    => MemoryTable p+    -> ArrayData a+    -> IO (Maybe (p b))+lookup (MemoryTable !ref _ _ _) !arr = do+  sa <- makeStableArray arr+  mw <- withMVar ref (`HT.lookup` sa)+  case mw of+    Nothing              -> trace ("lookup/not found: " ++ show sa) $ return Nothing+    Just (RemoteArray w p _) -> do+      mv <- deRefWeak w+      case mv of+        Just _ | Just p' <- gcast p -> trace ("lookup/found: " ++ show sa) $ return (Just p')+               | otherwise          -> $internalError "lookup" $ "type mismatch"++        -- Note: [Weak pointer weirdness]+        --+        -- After the lookup is successful, there might conceivably be no further+        -- references to 'arr'. If that is so, and a garbage collection+        -- intervenes, the weak pointer might get tombstoned before 'deRefWeak'+        -- gets to it. In that case we throw an error (below). However, because+        -- we have used 'arr' in the continuation, this ensures that 'arr' is+        -- reachable in the continuation of 'deRefWeak' and thus 'deRefWeak'+        -- always succeeds. This sort of weirdness, typical of the world of weak+        -- pointers, is why we can not reuse the stable name 'sa' computed+        -- above in the error message.+        --+        Nothing                     ->+          makeStableArray arr >>= \x -> $internalError "lookup" $ "dead weak pair: " ++ show x+++-- | Allocate a new device array to be associated with the given host-side array.+-- This may not always use the `malloc` provided by the `RemoteMemory` instance.+-- In order to reduce the number of raw allocations, previously allocated remote+-- arrays will be re-used. In the event that the remote memory is exhausted,+-- 'Nothing' is returned.+--+malloc :: forall a b m. (PrimElt a b, RemoteMemory m, MonadIO m)+       => MemoryTable (RemotePtr m)+       -> ArrayData a+       -> Int+       -> m (Maybe (RemotePtr m b))+malloc mt@(MemoryTable _ _ !nursery _) !ad !n = do+  -- Note: [Allocation sizes]+  --+  -- Instead of allocating the exact number of elements requested, we round up to+  -- a fixed chunk size as specified by RemoteMemory.remoteAllocationSize. This+  -- means there is a greater chance the nursery will get a hit, and moreover+  -- that we can search the nursery for an exact size.+  --+  chunk <- remoteAllocationSize+  let -- next highest multiple of f from x+      multiple x f      = (x + (f-1)) `div` f+      bytes             = chunk * multiple (n * sizeOf (undefined::b)) chunk+  --+  message ("malloc: " ++ showBytes bytes)+  mp <-+    fmap (castRemotePtr (Proxy :: Proxy m))+    <$> attempt "malloc/nursery" (liftIO $ N.lookup bytes nursery)+        `orElse`+        attempt "malloc/new" (mallocRemote bytes)+        `orElse` do message "malloc/remote-malloc-failed (cleaning)"+                    clean mt+                    liftIO $ N.lookup bytes nursery+        `orElse` do message "malloc/remote-malloc-failed (purging)"+                    purge mt+                    mallocRemote bytes+        `orElse` do message "malloc/remote-malloc-failed (non-recoverable)"+                    return Nothing+  case mp of+    Nothing -> return Nothing+    Just p' -> do+      insert mt ad p' bytes+      return (Just p')++  where+    orElse :: m (Maybe x) -> m (Maybe x) -> m (Maybe x)+    orElse ra rb = do+      ma <- ra+      case ma of+        Nothing -> rb+        Just a  -> return (Just a)++    attempt :: String -> m (Maybe x) -> m (Maybe x)+    attempt msg next = do+      ma <- next+      case ma of+        Nothing -> return Nothing+        Just a  -> trace msg (return (Just a))++++-- | Deallocate the device array associated with the given host-side array.+-- Typically this should only be called in very specific circumstances.+--+free :: (RemoteMemory m, PrimElt a b)+     => proxy m+     -> MemoryTable (RemotePtr m)+     -> ArrayData a+     -> IO ()+free proxy mt !arr = do+  sa <- makeStableArray arr+  freeStable proxy mt sa+++-- | Deallocate the device array associated with the given StableArray. This+-- is useful for other memory managers built on top of the memory table.+--+freeStable+    :: RemoteMemory m+    => proxy m+    -> MemoryTable (RemotePtr m)+    -> StableArray+    -> IO ()+freeStable proxy (MemoryTable !ref _ !nrs _) !sa =+  withMVar ref $ \mt -> do+    mw <- mt `HT.lookup` sa+    case mw of+      Nothing                        -> message ("free/already-removed: " ++ show sa)+      Just (RemoteArray _ !p !bytes) -> do+        message ("free/evict: " ++ show sa ++ " of " ++ showBytes bytes)+        N.insert bytes (castRemotePtr proxy p) nrs+        mt `HT.delete` sa+++-- Record an association between a host-side array and a new device memory area.+-- The device memory will be freed when the host array is garbage collected.+--+insert :: forall m a b. (PrimElt a b, RemoteMemory m, MonadIO m)+       => MemoryTable (RemotePtr m)+       -> ArrayData a+       -> RemotePtr m b+       -> Int+       -> m ()+insert mt@(MemoryTable !ref _ _ _) !arr !ptr !bytes = do+  key  <- makeStableArray  arr+  weak <- liftIO $ makeWeakArrayData arr () (Just $ freeStable (Proxy :: Proxy m) mt key)+  message $ "insert: " ++ show key+  liftIO  $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray weak ptr bytes)+++-- |Record an association between a host-side array and a remote memory area+-- that was not allocated by accelerate. The remote memory will NOT be re-used+-- once the host-side array is garbage collected.+--+-- This typically only has use for backends that provide an FFI.+--+insertUnmanaged+    :: (PrimElt a b, MonadIO m)+    => MemoryTable p+    -> ArrayData a+    -> p b+    -> m ()+insertUnmanaged (MemoryTable !ref !weak_ref _ _) !arr !ptr = do+  key  <- makeStableArray  arr+  weak <- liftIO $ makeWeakArrayData arr () (Just $ remoteFinalizer weak_ref key)+  message $ "insertUnmanaged: " ++ show key+  liftIO $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray weak ptr 0)+++-- Removing entries+-- ----------------++-- |Initiate garbage collection and mark any arrays that no longer have host-side+-- equivalents as reusable.+--+clean :: forall m. (RemoteMemory m, MonadIO m) => MemoryTable (RemotePtr m) -> m ()+clean mt@(MemoryTable _ weak_ref nrs _) = management "clean" nrs . liftIO $ do+  -- Unfortunately there is no real way to force a GC then wait for it to+  -- finish. Calling performGC then yielding works moderately well in+  -- single-threaded cases, but tends to fall down otherwise. Either way, given+  -- that finalizers are often significantly delayed, it is worth our while+  -- traversing the table and explicitly freeing any dead entires.+  --+  performGC+  yield+  mr <- deRefWeak weak_ref+  case mr of+    Nothing  -> return ()+    Just ref -> do+      rs <- withMVar ref $ HT.foldM removable []  -- collect arrays that can be removed+      mapM_ (freeStable (Proxy :: Proxy m) mt) rs -- remove them all+  where+    removable rs (sa, RemoteArray w _ _) = do+      alive <- isJust <$> deRefWeak w+      if alive+        then return rs+        else return (sa:rs)+++-- | Call `free` on all arrays that are not currently associated with host-side+-- arrays.+--+purge :: (RemoteMemory m, MonadIO m) => MemoryTable (RemotePtr m) -> m ()+purge (MemoryTable _ _ nursery@(Nursery nrs _) release)+  = management "purge" nursery+  $ liftIO (N.cleanup release nrs)+++-- |Initiate garbage collection and `free` any remote arrays that no longer+-- have matching host-side equivalents.+--+reclaim :: forall m. (RemoteMemory m, MonadIO m) => MemoryTable (RemotePtr m) -> m ()+reclaim mt = clean mt >> purge mt++remoteFinalizer :: Weak (MT p) -> StableArray -> IO ()+remoteFinalizer !weak_ref !key = do+  mr <- deRefWeak weak_ref+  case mr of+    Nothing  -> message ("finalise/dead table: " ++ show key)+    Just ref -> trace   ("finalise: "            ++ show key) $ withMVar ref (`HT.delete` key)+++-- Miscellaneous+-- -------------++-- | Make a new 'StableArray'.+--+{-# INLINE makeStableArray #-}+makeStableArray+    :: (MonadIO m, Typeable a, Typeable e, ArrayPtrs a ~ Ptr e, ArrayElt a)+    => ArrayData a+    -> m StableArray+makeStableArray !ad = return $! StableArray (id arrayElt ad)+  where+    id :: ArrayEltR e -> ArrayData e -> Unique+    id ArrayEltRint     (AD_Int ua)     = uniqueArrayId ua+    id ArrayEltRint8    (AD_Int8 ua)    = uniqueArrayId ua+    id ArrayEltRint16   (AD_Int16 ua)   = uniqueArrayId ua+    id ArrayEltRint32   (AD_Int32 ua)   = uniqueArrayId ua+    id ArrayEltRint64   (AD_Int64 ua)   = uniqueArrayId ua+    id ArrayEltRword    (AD_Word ua)    = uniqueArrayId ua+    id ArrayEltRword8   (AD_Word8 ua)   = uniqueArrayId ua+    id ArrayEltRword16  (AD_Word16 ua)  = uniqueArrayId ua+    id ArrayEltRword32  (AD_Word32 ua)  = uniqueArrayId ua+    id ArrayEltRword64  (AD_Word64 ua)  = uniqueArrayId ua+    id ArrayEltRcshort  (AD_CShort ua)  = uniqueArrayId ua+    id ArrayEltRcushort (AD_CUShort ua) = uniqueArrayId ua+    id ArrayEltRcint    (AD_CInt ua)    = uniqueArrayId ua+    id ArrayEltRcuint   (AD_CUInt ua)   = uniqueArrayId ua+    id ArrayEltRclong   (AD_CLong ua)   = uniqueArrayId ua+    id ArrayEltRculong  (AD_CULong ua)  = uniqueArrayId ua+    id ArrayEltRcllong  (AD_CLLong ua)  = uniqueArrayId ua+    id ArrayEltRcullong (AD_CULLong ua) = uniqueArrayId ua+    id ArrayEltRfloat   (AD_Float ua)   = uniqueArrayId ua+    id ArrayEltRdouble  (AD_Double ua)  = uniqueArrayId ua+    id ArrayEltRcfloat  (AD_CFloat ua)  = uniqueArrayId ua+    id ArrayEltRcdouble (AD_CDouble ua) = uniqueArrayId ua+    id ArrayEltRbool    (AD_Bool ua)    = uniqueArrayId ua+    id ArrayEltRchar    (AD_Char ua)    = uniqueArrayId ua+    id ArrayEltRcchar   (AD_CChar ua)   = uniqueArrayId ua+    id ArrayEltRcschar  (AD_CSChar ua)  = uniqueArrayId ua+    id ArrayEltRcuchar  (AD_CUChar ua)  = uniqueArrayId ua+    id _                _               = error "I do have a cause, though. It is obscenity. I'm for it."++-- Weak arrays+-- ----------------------++-- |Make a weak pointer using an array as a key. Unlike the standard `mkWeak`,+-- this guarantees finalisers won't fire early.+--+makeWeakArrayData+    :: forall a e c. (ArrayElt e, ArrayPtrs e ~ Ptr a)+    => ArrayData e+    -> c+    -> Maybe (IO ())+    -> IO (Weak c)+makeWeakArrayData !ad !c !mf = mw arrayElt ad+  where+    mw :: ArrayEltR e -> ArrayData e -> IO (Weak c)+    mw ArrayEltRint     (AD_Int ua)     = mkWeak' ua+    mw ArrayEltRint8    (AD_Int8 ua)    = mkWeak' ua+    mw ArrayEltRint16   (AD_Int16 ua)   = mkWeak' ua+    mw ArrayEltRint32   (AD_Int32 ua)   = mkWeak' ua+    mw ArrayEltRint64   (AD_Int64 ua)   = mkWeak' ua+    mw ArrayEltRword    (AD_Word ua)    = mkWeak' ua+    mw ArrayEltRword8   (AD_Word8 ua)   = mkWeak' ua+    mw ArrayEltRword16  (AD_Word16 ua)  = mkWeak' ua+    mw ArrayEltRword32  (AD_Word32 ua)  = mkWeak' ua+    mw ArrayEltRword64  (AD_Word64 ua)  = mkWeak' ua+    mw ArrayEltRcshort  (AD_CShort ua)  = mkWeak' ua+    mw ArrayEltRcushort (AD_CUShort ua) = mkWeak' ua+    mw ArrayEltRcint    (AD_CInt ua)    = mkWeak' ua+    mw ArrayEltRcuint   (AD_CUInt ua)   = mkWeak' ua+    mw ArrayEltRclong   (AD_CLong ua)   = mkWeak' ua+    mw ArrayEltRculong  (AD_CULong ua)  = mkWeak' ua+    mw ArrayEltRcllong  (AD_CLLong ua)  = mkWeak' ua+    mw ArrayEltRcullong (AD_CULLong ua) = mkWeak' ua+    mw ArrayEltRfloat   (AD_Float ua)   = mkWeak' ua+    mw ArrayEltRdouble  (AD_Double ua)  = mkWeak' ua+    mw ArrayEltRcfloat  (AD_CFloat ua)  = mkWeak' ua+    mw ArrayEltRcdouble (AD_CDouble ua) = mkWeak' ua+    mw ArrayEltRbool    (AD_Bool ua)    = mkWeak' ua+    mw ArrayEltRchar    (AD_Char ua)    = mkWeak' ua+    mw ArrayEltRcchar   (AD_CChar ua)   = mkWeak' ua+    mw ArrayEltRcschar  (AD_CSChar ua)  = mkWeak' ua+    mw ArrayEltRcuchar  (AD_CUChar ua)  = mkWeak' ua+#if __GLASGOW_HASKELL__ < 800+    mw _                _               = error "Base eight is just like base ten really - if you're missing two fingers."+#endif++    mkWeak' :: UniqueArray a -> IO (Weak c)+    mkWeak' !ua = do+      let !uad = uniqueArrayData ua+      case mf of+        Nothing -> return ()+        Just f  -> addFinalizer uad f+      mkWeak uad c+++-- Debug+-- -----++{-# INLINE showBytes #-}+showBytes :: Integral n => n -> String+showBytes x = D.showFFloatSIBase (Just 0) 1024 (fromIntegral x :: Double) "B"++{-# INLINE trace #-}+trace :: MonadIO m => String -> m a -> m a+trace msg next = message msg >> next++{-# INLINE message #-}+message :: MonadIO m => String -> m ()+message msg = liftIO $ D.traceIO D.dump_gc ("gc: " ++ msg)++{-# INLINE management #-}+management :: (RemoteMemory m, MonadIO m) => String -> Nursery p -> m a -> m a+management msg nrs next = do+  before     <- availableRemoteMem+  before_nrs <- liftIO $ N.size nrs+  total      <- totalRemoteMem+  r          <- next+  D.when D.dump_gc $ do+    after     <- availableRemoteMem+    after_nrs <- liftIO $ N.size nrs+    message $ msg ++ " (freed: "     ++ showBytes (after - before)+                  ++ ", stashed: "   ++ showBytes (before_nrs - after_nrs)+                  ++ ", remaining: " ++ showBytes after+                  ++ " of "          ++ showBytes total ++ ")"+  return r+

@@ -3,17 +3,19 @@ {-# LANGUAGE GADTs               #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TupleSections       #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE TypeOperators       #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module      : Data.Array.Accelerate.Array.Representation--- Copyright   : [2008..2014] Manuel M T Chakravarty, Gabriele Keller---               [2008..2009] Sean Lee---               [2009..2014] Trevor L. McDonell+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+--               [2013..2017] Robert Clifton-Everest+--               [2014..2014] Frederik M. Madsen -- License     : BSD3 ----- Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -23,6 +25,9 @@   -- * Array shapes, indices, and slices   Shape(..), Slice(..), SliceIndex(..), +  -- * Slice shape functions+  sliceShape, enumSlices,+ ) where  -- friends@@ -40,11 +45,13 @@ -- class (Eq sh, Slice sh) => Shape sh where   -- user-facing methods-  dim       :: sh -> Int             -- ^number of dimensions (>= 0); rank of the array+  rank      :: sh -> Int             -- ^number of dimensions (>= 0); rank of the array   size      :: sh -> Int             -- ^total number of elements in an array of this /shape/+  empty     :: sh                    -- ^empty shape.    -- internal methods   intersect :: sh -> sh -> sh  -- yield the intersection of two shapes+  union     :: sh -> sh -> sh  -- yield the union of two shapes   ignore    :: sh              -- identifies ignored elements in 'permute'   toIndex   :: sh -> sh -> Int -- yield the index position in a linear, row-major representation of                                -- the array (first argument is the shape)@@ -72,11 +79,12 @@   listToShape :: [Int] -> sh    -- convert a list of dimensions into a shape  instance Shape () where-  dim _             = 0-  size ()           = 1--  () `intersect` () = ()+  rank _            = 0+  empty             = ()   ignore            = ()+  () `intersect` () = ()+  () `union` ()     = ()+  size ()           = 1   toIndex () ()     = 0   fromIndex () _    = ()   bound () () _     = Right ()@@ -91,11 +99,15 @@   listToShape _  = $internalError "listToShape" "non-empty list when converting to unit"  instance Shape sh => Shape (sh, Int) where-  dim _                             = dim (undefined :: sh) + 1-  size (sh, sz)                     = size sh * sz--  (sh1, sz1) `intersect` (sh2, sz2) = (sh1 `intersect` sh2, sz1 `min` sz2)+  rank _                            = rank (undefined :: sh) + 1+  empty                             = (empty, 0)   ignore                            = (ignore, -1)+  (sh1, sz1) `intersect` (sh2, sz2) = (sh1 `intersect` sh2, sz1 `min` sz2)+  (sh1, sz1) `union` (sh2, sz2)     = (sh1 `union` sh2, sz1 `max` sz2)++  size (sh, sz)                     = $boundsCheck "size" "negative shape dimension" (sz >= 0)+                                    $ size sh * sz+   toIndex (sh, sz) (ix, i)          = $indexCheck "toIndex" i sz                                     $ toIndex sh ix * sz + i @@ -104,22 +116,30 @@     -- the remainder for the highest dimension since i < sz must hold.     --     where-      r | dim sh == 0   = $indexCheck "fromIndex" i sz i+      r | rank sh == 0  = $indexCheck "fromIndex" i sz i         | otherwise     = i `remInt` sz    bound (sh, sz) (ix, i) bndy     | i < 0                         = case bndy of-                                        Clamp      -> bound sh ix bndy `addDim` 0-                                        Mirror     -> bound sh ix bndy `addDim` (-i)-                                        Wrap       -> bound sh ix bndy `addDim` (sz+i)+                                        Clamp      -> next `addDim` 0+                                        Mirror     -> next `addDim` (-i)+                                        Wrap       -> next `addDim` (sz+i)                                         Constant e -> Left e     | i >= sz                       = case bndy of-                                        Clamp      -> bound sh ix bndy `addDim` (sz-1)-                                        Mirror     -> bound sh ix bndy `addDim` (sz-(i-sz+2))-                                        Wrap       -> bound sh ix bndy `addDim` (i-sz)+                                        Clamp      -> next `addDim` (sz-1)+                                        Mirror     -> next `addDim` (sz-(i-sz+2))+                                        Wrap       -> next `addDim` (i-sz)                                         Constant e -> Left e-    | otherwise                     = bound sh ix bndy `addDim` i+    | otherwise                     = next `addDim` i     where+      -- This function is quite difficult to optimize due to the deep recursion+      -- that is can generate with high-dimensional arrays. If we let 'next' be+      -- inlined into each alternative of the cases above the size of this+      -- function on an n-dimensional array will grow as 7^n. This quickly causes+      -- GHC's head to explode. See GHC Trac #10491 for more details.+      next = bound sh ix bndy+      {-# NOINLINE next #-}+       Right ds `addDim` d = Right (ds, d)       Left e   `addDim` _ = Left e @@ -190,4 +210,28 @@   show SliceNil          = "SliceNil"   show (SliceAll rest)   = "SliceAll (" ++ show rest ++ ")"   show (SliceFixed rest) = "SliceFixed (" ++ show rest ++ ")"++-- | Project the shape of a slice from the full shape.+--+sliceShape :: forall slix co sl dim.+              SliceIndex slix sl co dim+           -> dim+           -> sl+sliceShape SliceNil        ()      = ()+sliceShape (SliceAll   sl) (sh, n) = (sliceShape sl sh, n)+sliceShape (SliceFixed sl) (sh, _) = sliceShape sl sh+++-- | Enumerate all slices within a given bound. The innermost dimension changes+-- most rapidly.+--+-- See 'Data.Array.Accelerate.Array.Sugar.enumSlices' for an example.+--+enumSlices :: forall slix co sl dim.+              SliceIndex slix sl co dim+           -> dim+           -> [slix]+enumSlices SliceNil        ()       = [()]+enumSlices (SliceAll   sl) (sh, _)  = [ (sh', ()) | sh' <- enumSlices sl sh]+enumSlices (SliceFixed sl) (sh, n)  = [ (sh', i)  | sh' <- enumSlices sl sh, i <- [0..n-1]] 

@@ -1,1148 +1,1292 @@-{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE TupleSections       #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE TypeOperators       #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Array.Sugar--- Copyright   : [2008..2014] Manuel M T Chakravarty, Gabriele Keller---               [2008..2009] Sean Lee---               [2009..2014] Trevor L. McDonell---               [2013..2014] Robert Clifton-Everest--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.Array.Sugar (--  -- * Array representation-  Array(..), Scalar, Vector, Segments,-  Arrays(..), ArraysR(..), ArrRepr, ArrRepr',--  -- * Class of supported surface element types and their mapping to representation types-  Elt(..), EltRepr, EltRepr',--  -- * Derived functions-  liftToElt, liftToElt2, sinkFromElt, sinkFromElt2,--  -- * Array shapes-  DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9,--  -- * Array indexing and slicing-  Z(..), (:.)(..), All(..), Any(..), Shape(..), Slice(..),--  -- * Array shape query, indexing, and conversions-  shape, (!), newArray, allocateArray, fromIArray, toIArray, fromList, toList,--  -- * Miscellaneous-  showShape, Foreign(..)--) where---- standard library-import Data.Typeable-import Data.Array.IArray                                        ( IArray )-import qualified Data.Array.IArray                              as IArray--import GHC.Exts                                                 ( IsList )-import qualified GHC.Exts                                       as GHC---- friends-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Array.Data-import qualified Data.Array.Accelerate.Array.Representation     as Repr----- Surface types representing array indices and slices--- --------------------------------------------------------- Array indices are snoc type lists.  That is, they're backwards ----- the end-of-list token, `Z`, occurs first.  For example, the type of a--- rank-2 array index is @Z :. Int :. Int@.------ In Accelerate the rightmost dimension is the /fastest varying/ or innermost.---- |Rank-0 index----data Z = Z-  deriving (Typeable, Show, Eq)---- |Increase an index rank by one dimension.  The `:.` operator is---  used to construct both values and types.----infixl 3 :.-data tail :. head = tail :. head-  deriving (Typeable, Show, Eq)---- | Marker for entire dimensions in slice descriptors.------ For example, when used in slices passed to `Data.Array.Accelerate.replicate`,--- the occurrences of `All` indicate the dimensions into which the array's--- existing extent will be placed, rather than the new dimensions introduced by--- replication.----data All = All-  deriving (Typeable, Show, Eq)---- |Marker for arbitrary shapes in slice descriptors.  Such arbitrary---  shapes may include an unknown number of dimensions.------  `Any` can be used in the leftmost position of a slice instead of---  `Z`, for example @(Any :. _ :. _)@.  In the following definition---  `Any` is used to match against whatever shape the type variable---  `sh` takes:------ > repN :: (Shape sh, Elt e) => Int -> Acc (Array sh e) -> Acc (Array (sh:.Int) e)--- > repN n a = replicate (constant $ Any :. n) a----data Any sh = Any-  deriving (Typeable, Show, Eq)---- Representation change for array element types--- ------------------------------------------------- | Type representation mapping------ We represent tuples by using '()' and '(,)' as type-level nil and snoc to--- construct snoc-lists of types.----type family EltRepr a :: *-type instance EltRepr () = ()-type instance EltRepr Z = ()-type instance EltRepr (t:.h) = (EltRepr t, EltRepr' h)-type instance EltRepr All = ((), ())-type instance EltRepr (Any Z) = ()-type instance EltRepr (Any (sh:.Int)) = (EltRepr (Any sh), ())-type instance EltRepr Int = ((), Int)-type instance EltRepr Int8 = ((), Int8)-type instance EltRepr Int16 = ((), Int16)-type instance EltRepr Int32 = ((), Int32)-type instance EltRepr Int64 = ((), Int64)-type instance EltRepr Word = ((), Word)-type instance EltRepr Word8 = ((), Word8)-type instance EltRepr Word16 = ((), Word16)-type instance EltRepr Word32 = ((), Word32)-type instance EltRepr Word64 = ((), Word64)-type instance EltRepr CShort = ((), CShort)-type instance EltRepr CUShort = ((), CUShort)-type instance EltRepr CInt = ((), CInt)-type instance EltRepr CUInt = ((), CUInt)-type instance EltRepr CLong = ((), CLong)-type instance EltRepr CULong = ((), CULong)-type instance EltRepr CLLong = ((), CLLong)-type instance EltRepr CULLong = ((), CULLong)-type instance EltRepr Float = ((), Float)-type instance EltRepr Double = ((), Double)-type instance EltRepr CFloat = ((), CFloat)-type instance EltRepr CDouble = ((), CDouble)-type instance EltRepr Bool = ((), Bool)-type instance EltRepr Char = ((), Char)-type instance EltRepr CChar = ((), CChar)-type instance EltRepr CSChar = ((), CSChar)-type instance EltRepr CUChar = ((), CUChar)-type instance EltRepr (a, b) = (EltRepr a, EltRepr' b)-type instance EltRepr (a, b, c) = (EltRepr (a, b), EltRepr' c)-type instance EltRepr (a, b, c, d) = (EltRepr (a, b, c), EltRepr' d)-type instance EltRepr (a, b, c, d, e) = (EltRepr (a, b, c, d), EltRepr' e)-type instance EltRepr (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f)-type instance EltRepr (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g)-type instance EltRepr (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h)-type instance EltRepr (a, b, c, d, e, f, g, h, i)-  = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i)---- To avoid overly nested pairs, we use a flattened representation at the--- leaves.----type family EltRepr' a :: *-type instance EltRepr' () = ()-type instance EltRepr' Z = ()-type instance EltRepr' (t:.h) = (EltRepr t, EltRepr' h)-type instance EltRepr' All = ()-type instance EltRepr' (Any Z) = ()-type instance EltRepr' (Any (sh:.Int)) = (EltRepr' (Any sh), ())-type instance EltRepr' Int = Int-type instance EltRepr' Int8 = Int8-type instance EltRepr' Int16 = Int16-type instance EltRepr' Int32 = Int32-type instance EltRepr' Int64 = Int64-type instance EltRepr' Word = Word-type instance EltRepr' Word8 = Word8-type instance EltRepr' Word16 = Word16-type instance EltRepr' Word32 = Word32-type instance EltRepr' Word64 = Word64-type instance EltRepr' CShort = CShort-type instance EltRepr' CUShort = CUShort-type instance EltRepr' CInt = CInt-type instance EltRepr' CUInt = CUInt-type instance EltRepr' CLong = CLong-type instance EltRepr' CULong = CULong-type instance EltRepr' CLLong = CLLong-type instance EltRepr' CULLong = CULLong-type instance EltRepr' Float = Float-type instance EltRepr' Double = Double-type instance EltRepr' CFloat = CFloat-type instance EltRepr' CDouble = CDouble-type instance EltRepr' Bool = Bool-type instance EltRepr' Char = Char-type instance EltRepr' CChar = CChar-type instance EltRepr' CSChar = CSChar-type instance EltRepr' CUChar = CUChar-type instance EltRepr' (a, b) = (EltRepr a, EltRepr' b)-type instance EltRepr' (a, b, c) = (EltRepr (a, b), EltRepr' c)-type instance EltRepr' (a, b, c, d) = (EltRepr (a, b, c), EltRepr' d)-type instance EltRepr' (a, b, c, d, e) = (EltRepr (a, b, c, d), EltRepr' e)-type instance EltRepr' (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f)-type instance EltRepr' (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g)-type instance EltRepr' (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h)-type instance EltRepr' (a, b, c, d, e, f, g, h, i)-  = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i)----- Array elements (tuples of scalars)--- -------------------------------------- | Accelerate supports as array elements only simple atomic types, and tuples--- thereof. These element types are stored efficiently in memory, unpacked as--- consecutive elements without pointers.------ This class characterises the types of values that can be array elements, and--- hence, appear in scalar Accelerate expressions.----class (Show a, Typeable a,-       Typeable (EltRepr a), Typeable (EltRepr' a),-       ArrayElt (EltRepr a), ArrayElt (EltRepr' a))-      => Elt a where-  eltType  :: {-dummy-} a -> TupleType (EltRepr a)-  fromElt  :: a -> EltRepr a-  toElt    :: EltRepr a -> a--  eltType' :: {-dummy-} a -> TupleType (EltRepr' a)-  fromElt' :: a -> EltRepr' a-  toElt'   :: EltRepr' a -> a--instance Elt () where-  eltType _ = UnitTuple-  fromElt = id-  toElt   = id--  eltType' _ = UnitTuple-  fromElt' = id-  toElt'   = id--instance Elt Z where-  eltType _ = UnitTuple-  fromElt Z = ()-  toElt ()  = Z--  eltType' _ = UnitTuple-  fromElt' Z = ()-  toElt' ()  = Z--instance (Elt t, Elt h) => Elt (t:.h) where-  eltType (_::(t:.h)) = PairTuple (eltType (undefined :: t)) (eltType' (undefined :: h))-  fromElt (t:.h)      = (fromElt t, fromElt' h)-  toElt (t, h)        = toElt t :. toElt' h--  eltType' (_::(t:.h)) = PairTuple (eltType (undefined :: t)) (eltType' (undefined :: h))-  fromElt' (t:.h)      = (fromElt t, fromElt' h)-  toElt' (t, h)        = toElt t :. toElt' h--instance Elt All where-  eltType _      = PairTuple UnitTuple UnitTuple-  fromElt All    = ((), ())-  toElt ((), ()) = All--  eltType' _     = UnitTuple-  fromElt' All   = ()-  toElt' ()      = All--instance Elt (Any Z) where-  eltType _ = UnitTuple-  fromElt _ = ()-  toElt _   = Any--  eltType' _ = UnitTuple-  fromElt' _ = ()-  toElt' _   = Any--instance Shape sh => Elt (Any (sh:.Int)) where-  eltType _ = PairTuple (eltType (undefined::Any sh)) UnitTuple-  fromElt _ = (fromElt (undefined :: Any sh), ())-  toElt _   = Any--  eltType' _ = PairTuple (eltType' (undefined::Any sh)) UnitTuple-  fromElt' _ = (fromElt' (undefined :: Any sh), ())-  toElt' _   = Any--instance Elt Int where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt Int8 where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt Int16 where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt Int32 where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt Int64 where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt Word where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt Word8 where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt Word16 where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt Word32 where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt Word64 where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id---instance Elt CShort where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt CUShort where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt CInt where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt CUInt where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt CLong where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt CULong where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt CLLong where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt CULLong where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt Float where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt Double where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt CFloat where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt CDouble where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id---instance Elt Bool where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt Char where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt CChar where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt CSChar where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance Elt CUChar where-  eltType       = singletonScalarType-  fromElt v     = ((), v)-  toElt ((), v) = v--  eltType' _    = SingleTuple scalarType-  fromElt'      = id-  toElt'        = id--instance (Elt a, Elt b) => Elt (a, b) where-  eltType (_::(a, b))-    = PairTuple (eltType (undefined :: a)) (eltType' (undefined :: b))-  fromElt (a, b)  = (fromElt a, fromElt' b)-  toElt (a, b)  = (toElt a, toElt' b)--  eltType' (_::(a, b))-    = PairTuple (eltType (undefined :: a)) (eltType' (undefined :: b))-  fromElt' (a, b) = (fromElt a, fromElt' b)-  toElt' (a, b) = (toElt a, toElt' b)--instance (Elt a, Elt b, Elt c) => Elt (a, b, c) where-  eltType (_::(a, b, c))-    = PairTuple (eltType (undefined :: (a, b))) (eltType' (undefined :: c))-  fromElt (a, b, c) = (fromElt (a, b), fromElt' c)-  toElt (ab, c) = let (a, b) = toElt ab in (a, b, toElt' c)--  eltType' (_::(a, b, c))-    = PairTuple (eltType (undefined :: (a, b))) (eltType' (undefined :: c))-  fromElt' (a, b, c) = (fromElt (a, b), fromElt' c)-  toElt' (ab, c) = let (a, b) = toElt ab in (a, b, toElt' c)--instance (Elt a, Elt b, Elt c, Elt d) => Elt (a, b, c, d) where-  eltType (_::(a, b, c, d))-    = PairTuple (eltType (undefined :: (a, b, c))) (eltType' (undefined :: d))-  fromElt (a, b, c, d) = (fromElt (a, b, c), fromElt' d)-  toElt (abc, d) = let (a, b, c) = toElt abc in (a, b, c, toElt' d)--  eltType' (_::(a, b, c, d))-    = PairTuple (eltType (undefined :: (a, b, c))) (eltType' (undefined :: d))-  fromElt' (a, b, c, d) = (fromElt (a, b, c), fromElt' d)-  toElt' (abc, d) = let (a, b, c) = toElt abc in (a, b, c, toElt' d)--instance (Elt a, Elt b, Elt c, Elt d, Elt e) => Elt (a, b, c, d, e) where-  eltType (_::(a, b, c, d, e))-    = PairTuple (eltType (undefined :: (a, b, c, d)))-                (eltType' (undefined :: e))-  fromElt (a, b, c, d, e) = (fromElt (a, b, c, d), fromElt' e)-  toElt (abcd, e) = let (a, b, c, d) = toElt abcd in (a, b, c, d, toElt' e)--  eltType' (_::(a, b, c, d, e))-    = PairTuple (eltType (undefined :: (a, b, c, d)))-                (eltType' (undefined :: e))-  fromElt' (a, b, c, d, e) = (fromElt (a, b, c, d), fromElt' e)-  toElt' (abcd, e) = let (a, b, c, d) = toElt abcd in (a, b, c, d, toElt' e)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) => Elt (a, b, c, d, e, f) where-  eltType (_::(a, b, c, d, e, f))-    = PairTuple (eltType (undefined :: (a, b, c, d, e)))-                (eltType' (undefined :: f))-  fromElt (a, b, c, d, e, f) = (fromElt (a, b, c, d, e), fromElt' f)-  toElt (abcde, f) = let (a, b, c, d, e) = toElt abcde in (a, b, c, d, e, toElt' f)--  eltType' (_::(a, b, c, d, e, f))-    = PairTuple (eltType (undefined :: (a, b, c, d, e)))-                (eltType' (undefined :: f))-  fromElt' (a, b, c, d, e, f) = (fromElt (a, b, c, d, e), fromElt' f)-  toElt' (abcde, f) = let (a, b, c, d, e) = toElt abcde in (a, b, c, d, e, toElt' f)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)-  => Elt (a, b, c, d, e, f, g) where-  eltType (_::(a, b, c, d, e, f, g))-    = PairTuple (eltType (undefined :: (a, b, c, d, e, f)))-                (eltType' (undefined :: g))-  fromElt (a, b, c, d, e, f, g) = (fromElt (a, b, c, d, e, f), fromElt' g)-  toElt (abcdef, g) = let (a, b, c, d, e, f) = toElt abcdef in (a, b, c, d, e, f, toElt' g)--  eltType' (_::(a, b, c, d, e, f, g))-    = PairTuple (eltType (undefined :: (a, b, c, d, e, f)))-                (eltType' (undefined :: g))-  fromElt' (a, b, c, d, e, f, g) = (fromElt (a, b, c, d, e, f), fromElt' g)-  toElt' (abcdef, g) = let (a, b, c, d, e, f) = toElt abcdef in (a, b, c, d, e, f, toElt' g)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)-  => Elt (a, b, c, d, e, f, g, h) where-  eltType (_::(a, b, c, d, e, f, g, h))-    = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g)))-                (eltType' (undefined :: h))-  fromElt (a, b, c, d, e, f, g, h) = (fromElt (a, b, c, d, e, f, g), fromElt' h)-  toElt (abcdefg, h) = let (a, b, c, d, e, f, g) = toElt abcdefg-                        in (a, b, c, d, e, f, g, toElt' h)--  eltType' (_::(a, b, c, d, e, f, g, h))-    = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g)))-                (eltType' (undefined :: h))-  fromElt' (a, b, c, d, e, f, g, h) = (fromElt (a, b, c, d, e, f, g), fromElt' h)-  toElt' (abcdefg, h) = let (a, b, c, d, e, f, g) = toElt abcdefg-                         in (a, b, c, d, e, f, g, toElt' h)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)-  => Elt (a, b, c, d, e, f, g, h, i) where-  eltType (_::(a, b, c, d, e, f, g, h, i))-    = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h)))-                (eltType' (undefined :: i))-  fromElt (a, b, c, d, e, f, g, h, i) = (fromElt (a, b, c, d, e, f, g, h), fromElt' i)-  toElt (abcdefgh, i) = let (a, b, c, d, e, f, g, h) = toElt abcdefgh-                        in (a, b, c, d, e, f, g, h, toElt' i)--  eltType' (_::(a, b, c, d, e, f, g, h, i))-    = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h)))-                (eltType' (undefined :: i))-  fromElt' (a, b, c, d, e, f, g, h, i) = (fromElt (a, b, c, d, e, f, g, h), fromElt' i)-  toElt' (abcdefgh, i) = let (a, b, c, d, e, f, g, h) = toElt abcdefgh-                         in (a, b, c, d, e, f, g, h, toElt' i)---- |Convenience functions-----singletonScalarType :: IsScalar a => a -> TupleType ((), a)-singletonScalarType _ = PairTuple UnitTuple (SingleTuple scalarType)--liftToElt :: (Elt a, Elt b)-          => (EltRepr a -> EltRepr b)-          -> (a -> b)-{-# INLINE liftToElt #-}-liftToElt f = toElt . f . fromElt--liftToElt2 :: (Elt a, Elt b, Elt c)-           => (EltRepr a -> EltRepr b -> EltRepr c)-           -> (a -> b -> c)-{-# INLINE liftToElt2 #-}-liftToElt2 f = \x y -> toElt $ f (fromElt x) (fromElt y)--sinkFromElt :: (Elt a, Elt b)-            => (a -> b)-            -> (EltRepr a -> EltRepr b)-{-# INLINE sinkFromElt #-}-sinkFromElt f = fromElt . f . toElt--sinkFromElt2 :: (Elt a, Elt b, Elt c)-             => (a -> b -> c)-             -> (EltRepr a -> EltRepr b -> EltRepr c)-{-# INLINE sinkFromElt2 #-}-sinkFromElt2 f = \x y -> fromElt $ f (toElt x) (toElt y)--{-# RULES--"fromElt/toElt" forall e.-  fromElt (toElt e) = e--"toElt/fromElt" forall e.-  toElt (fromElt e) = e #-}----- Foreign functions--- --------------------- Class for backends to choose their own representation of foreign functions.--- By default it has no instances. If a backend wishes to have an FFI it must--- provide an instance.----class Typeable f => Foreign (f :: * -> * -> *) where--  -- Backends should be able to produce a string representation of the foreign-  -- function for pretty printing, typically the name of the function.-  strForeign :: f args results -> String----- Surface arrays--- ------------------ We represent tuples of arrays in the same way as tuples of scalars; using--- '()' and '(,)' as type-level nil and snoc. This characterises the domain of--- results of Accelerate array computations.----type family ArrRepr a :: *-type instance ArrRepr () = ()-type instance ArrRepr (Array sh e) = ((), Array sh e)-type instance ArrRepr (b, a) = (ArrRepr b, ArrRepr' a)-type instance ArrRepr (c, b, a) = (ArrRepr (c, b), ArrRepr' a)-type instance ArrRepr (d, c, b, a) = (ArrRepr (d, c, b), ArrRepr' a)-type instance ArrRepr (e, d, c, b, a) = (ArrRepr (e, d, c, b), ArrRepr' a)-type instance ArrRepr (f, e, d, c, b, a) = (ArrRepr (f, e, d, c, b), ArrRepr' a)-type instance ArrRepr (g, f, e, d, c, b, a) = (ArrRepr (g, f, e, d, c, b), ArrRepr' a)-type instance ArrRepr (h, g, f, e, d, c, b, a) = (ArrRepr (h, g, f, e, d, c, b), ArrRepr' a)-type instance ArrRepr (i, h, g, f, e, d, c, b, a) = (ArrRepr (i, h, g, f, e, d, c, b), ArrRepr' a)--type family ArrRepr' a :: *-type instance ArrRepr' () = ()-type instance ArrRepr' (Array sh e) = Array sh e-type instance ArrRepr' (b, a) = (ArrRepr b, ArrRepr' a)-type instance ArrRepr' (c, b, a) = (ArrRepr (c, b), ArrRepr' a)-type instance ArrRepr' (d, c, b, a) = (ArrRepr (d, c, b), ArrRepr' a)-type instance ArrRepr' (e, d, c, b, a) = (ArrRepr (e, d, c, b), ArrRepr' a)-type instance ArrRepr' (f, e, d, c, b, a) = (ArrRepr (f, e, d, c, b), ArrRepr' a)-type instance ArrRepr' (g, f, e, d, c, b, a) = (ArrRepr (g, f, e, d, c, b), ArrRepr' a)-type instance ArrRepr' (h, g, f, e, d, c, b, a) = (ArrRepr (h, g, f, e, d, c, b), ArrRepr' a)-type instance ArrRepr' (i, h, g, f, e, d, c, b, a) = (ArrRepr (i, h, g, f, e, d, c, b), ArrRepr' a)---- Array type reification----data ArraysR arrs where-  ArraysRunit  ::                                   ArraysR ()-  ArraysRarray :: (Shape sh, Elt e) =>              ArraysR (Array sh e)-  ArraysRpair  :: ArraysR arrs1 -> ArraysR arrs2 -> ArraysR (arrs1, arrs2)--class (Typeable (ArrRepr a), Typeable (ArrRepr' a), Typeable a) => Arrays a where-  arrays   :: a {- dummy -} -> ArraysR (ArrRepr  a)-  arrays'  :: a {- dummy -} -> ArraysR (ArrRepr' a)-  ---  toArr    :: ArrRepr  a -> a-  toArr'   :: ArrRepr' a -> a-  fromArr  :: a -> ArrRepr  a-  fromArr' :: a -> ArrRepr' a---instance Arrays () where-  arrays  _ = ArraysRunit-  arrays' _ = ArraysRunit-  ---  toArr     = id-  toArr'    = id-  fromArr   = id-  fromArr'  = id--instance (Shape sh, Elt e) => Arrays (Array sh e) where-  arrays  _       = ArraysRpair ArraysRunit ArraysRarray-  arrays' _       = ArraysRarray-  ---  toArr ((), arr) = arr-  toArr'          = id-  fromArr arr     = ((), arr)-  fromArr'        = id--instance (Arrays b, Arrays a) => Arrays (b, a) where-  arrays  _ = ArraysRpair (arrays (undefined::b)) (arrays' (undefined::a))-  arrays' _ = ArraysRpair (arrays (undefined::b)) (arrays' (undefined::a))-  ---  toArr    (b, a) = (toArr b, toArr' a)-  toArr'   (b, a) = (toArr b, toArr' a)-  fromArr  (b, a) = (fromArr b, fromArr' a)-  fromArr' (b, a) = (fromArr b, fromArr' a)--instance (Arrays c, Arrays b, Arrays a) => Arrays (c, b, a) where-  arrays  _ = ArraysRpair (arrays (undefined::(c,b))) (arrays' (undefined::a))-  arrays' _ = ArraysRpair (arrays (undefined::(c,b))) (arrays' (undefined::a))-  ---  toArr    (cb, a) = let (c, b) = toArr cb in (c, b, toArr' a)-  toArr'   (cb, a) = let (c, b) = toArr cb in (c, b, toArr' a)-  fromArr  (c, b, a) = (fromArr (c, b), fromArr' a)-  fromArr' (c, b, a) = (fromArr (c, b), fromArr' a)--instance (Arrays d, Arrays c, Arrays b, Arrays a) => Arrays (d, c, b, a) where-  arrays  _ = ArraysRpair (arrays (undefined::(d,c,b))) (arrays' (undefined::a))-  arrays' _ = ArraysRpair (arrays (undefined::(d,c,b))) (arrays' (undefined::a))-  ---  toArr    (dcb, a) = let (d, c, b) = toArr dcb in (d, c, b, toArr' a)-  toArr'   (dcb, a) = let (d, c, b) = toArr dcb in (d, c, b, toArr' a)-  fromArr  (d, c, b, a) = (fromArr (d, c, b), fromArr' a)-  fromArr' (d, c, b, a) = (fromArr (d, c, b), fromArr' a)--instance (Arrays e, Arrays d, Arrays c, Arrays b, Arrays a) => Arrays (e, d, c, b, a) where-  arrays  _ = ArraysRpair (arrays (undefined::(e,d,c,b))) (arrays' (undefined::a))-  arrays' _ = ArraysRpair (arrays (undefined::(e,d,c,b))) (arrays' (undefined::a))-  ---  toArr    (edcb, a) = let (e, d, c, b) = toArr edcb in (e, d, c, b, toArr' a)-  toArr'   (edcb, a) = let (e, d, c, b) = toArr edcb in (e, d, c, b, toArr' a)-  fromArr  (e, d, c, b, a) = (fromArr (e, d, c, b), fromArr' a)-  fromArr' (e, d, c, b, a) = (fromArr (e, d, c, b), fromArr' a)--instance (Arrays f, Arrays e, Arrays d, Arrays c, Arrays b, Arrays a)-  => Arrays (f, e, d, c, b, a) where-  arrays  _ = ArraysRpair (arrays (undefined::(f,e,d,c,b))) (arrays' (undefined::a))-  arrays' _ = ArraysRpair (arrays (undefined::(f,e,d,c,b))) (arrays' (undefined::a))-  ---  toArr    (fedcb, a) = let (f, e, d, c, b) = toArr fedcb in (f, e, d, c, b, toArr' a)-  toArr'   (fedcb, a) = let (f, e, d, c, b) = toArr fedcb in (f, e, d, c, b, toArr' a)-  fromArr  (f, e, d, c, b, a) = (fromArr (f, e, d, c, b), fromArr' a)-  fromArr' (f, e, d, c, b, a) = (fromArr (f, e, d, c, b), fromArr' a)--instance (Arrays g, Arrays f, Arrays e, Arrays d, Arrays c, Arrays b, Arrays a)-  => Arrays (g, f, e, d, c, b, a) where-  arrays  _ = ArraysRpair (arrays (undefined::(g,f,e,d,c,b))) (arrays' (undefined::a))-  arrays' _ = ArraysRpair (arrays (undefined::(g,f,e,d,c,b))) (arrays' (undefined::a))-  ---  toArr    (gfedcb, a) = let (g, f, e, d, c, b) = toArr gfedcb in (g, f, e, d, c, b, toArr' a)-  toArr'   (gfedcb, a) = let (g, f, e, d, c, b) = toArr gfedcb in (g, f, e, d, c, b, toArr' a)-  fromArr  (g, f, e, d, c, b, a) = (fromArr (g, f, e, d, c, b), fromArr' a)-  fromArr' (g, f, e, d, c, b, a) = (fromArr (g, f, e, d, c, b), fromArr' a)--instance (Arrays h, Arrays g, Arrays f, Arrays e, Arrays d, Arrays c, Arrays b, Arrays a)-  => Arrays (h, g, f, e, d, c, b, a) where-  arrays  _ = ArraysRpair (arrays (undefined::(h,g,f,e,d,c,b))) (arrays' (undefined::a))-  arrays' _ = ArraysRpair (arrays (undefined::(h,g,f,e,d,c,b))) (arrays' (undefined::a))-  ---  toArr    (hgfedcb, a) = let (h, g, f, e, d, c, b) = toArr hgfedcb in (h, g, f, e, d, c, b, toArr' a)-  toArr'   (hgfedcb, a) = let (h, g, f, e, d, c, b) = toArr hgfedcb in (h, g, f, e, d, c, b, toArr' a)-  fromArr  (h, g, f, e, d, c, b, a) = (fromArr (h, g, f, e, d, c, b), fromArr' a)-  fromArr' (h, g, f, e, d, c, b, a) = (fromArr (h, g, f, e, d, c, b), fromArr' a)--instance (Arrays i, Arrays h, Arrays g, Arrays f, Arrays e, Arrays d, Arrays c, Arrays b, Arrays a)-  => Arrays (i, h, g, f, e, d, c, b, a) where-  arrays  _ = ArraysRpair (arrays (undefined::(i,h,g,f,e,d,c,b))) (arrays' (undefined::a))-  arrays' _ = ArraysRpair (arrays (undefined::(i,h,g,f,e,d,c,b))) (arrays' (undefined::a))-  ---  toArr    (ihgfedcb, a) = let (i, h, g, f, e, d, c, b) = toArr ihgfedcb in (i, h, g, f, e, d, c, b, toArr' a)-  toArr'   (ihgfedcb, a) = let (i, h, g, f, e, d, c, b) = toArr ihgfedcb in (i, h, g, f, e, d, c, b, toArr' a)-  fromArr  (i, h, g, f, e, d, c, b, a) = (fromArr (i, h, g, f, e, d, c, b), fromArr' a)-  fromArr' (i, h, g, f, e, d, c, b, a) = (fromArr (i, h, g, f, e, d, c, b), fromArr' a)--{-# RULES--"fromArr/toArr" forall a.-  fromArr (toArr a) = a--"toArr/fromArr" forall a.-  toArr (fromArr a) = a #-}----- |Multi-dimensional arrays for array processing.------ If device and host memory are separate, arrays will be transferred to the--- device when necessary (if possible asynchronously and in parallel with other--- tasks) and cached on the device if sufficient memory is available.----data Array sh e where-  Array :: (Shape sh, Elt e)-        => EltRepr sh                 -- extent of dimensions = shape-        -> ArrayData (EltRepr e)      -- array payload-        -> Array sh e--deriving instance Typeable Array---- |Scalars arrays hold a single element----type Scalar e = Array DIM0 e---- |Vectors are one-dimensional arrays----type Vector e = Array DIM1 e---- |Segment descriptor (vector of segment lengths).------ To represent nested one-dimensional arrays, we use a flat array of data--- values in conjunction with a /segment descriptor/, which stores the lengths--- of the subarrays.----type Segments i = Vector i---- Shorthand for common shape types----type DIM0 = Z-type DIM1 = DIM0:.Int-type DIM2 = DIM1:.Int-type DIM3 = DIM2:.Int-type DIM4 = DIM3:.Int-type DIM5 = DIM4:.Int-type DIM6 = DIM5:.Int-type DIM7 = DIM6:.Int-type DIM8 = DIM7:.Int-type DIM9 = DIM8:.Int---- Shape constraints and indexing--- ---------------------------------- |Shapes and indices of multi-dimensional arrays----class (Elt sh, Elt (Any sh), Repr.Shape (EltRepr sh)) => Shape sh where--  -- |Number of dimensions of a /shape/ or /index/ (>= 0).-  dim    :: sh -> Int--  -- |Total number of elements in an array of the given /shape/.-  size   :: sh -> Int--  -- |Magic value identifying elements ignored in 'permute'.-  ignore :: sh--  -- |Yield the intersection of two shapes-  intersect :: sh -> sh -> sh--  -- |Map a multi-dimensional index into one in a linear, row-major-  -- representation of the array (first argument is the /shape/, second-  -- argument is the index).-  toIndex   :: sh -> sh -> Int--  -- |Inverse of 'toIndex'.-  fromIndex :: sh -> Int -> sh--  -- |Apply a boundary condition to an index.-  bound  :: sh -> sh -> Boundary a -> Either a sh--  -- |Iterate through the entire shape, applying the function; third argument-  -- combines results and fourth is returned in case of an empty iteration-  -- space; the index space is traversed in row-major order.-  iter  :: sh -> (sh -> a) -> (a -> a -> a) -> a -> a--  -- |Variant of 'iter' without an initial value-  iter1 :: sh -> (sh -> a) -> (a -> a -> a) -> a--  -- |Convert a minpoint-maxpoint index into a /shape/.-  rangeToShape ::  (sh, sh) -> sh--  -- |Convert a /shape/ into a minpoint-maxpoint index.-  shapeToRange ::  sh -> (sh, sh)--  -- |Convert a shape to a list of dimensions.-  shapeToList :: sh -> [Int]--  -- |Convert a list of dimensions into a shape.-  listToShape :: [Int] -> sh--  -- | The slice index for slice specifier 'Any sh'-  sliceAnyIndex :: sh -> Repr.SliceIndex (EltRepr (Any sh)) (EltRepr sh) () (EltRepr sh)--  dim                   = Repr.dim . fromElt-  size                  = Repr.size . fromElt-  -- (#) must be individually defined, as it holds for all instances *except*-  -- the one with the largest arity--  ignore                = toElt Repr.ignore-  intersect sh1 sh2     = toElt (Repr.intersect (fromElt sh1) (fromElt sh2))-  fromIndex sh ix       = toElt (Repr.fromIndex (fromElt sh) ix)-  toIndex sh ix         = Repr.toIndex (fromElt sh) (fromElt ix)--  bound sh ix bndy      = case Repr.bound (fromElt sh) (fromElt ix) bndy of-                            Left v    -> Left v-                            Right ix' -> Right $ toElt ix'--  iter sh f c r         = Repr.iter  (fromElt sh) (f . toElt) c r-  iter1 sh f r          = Repr.iter1 (fromElt sh) (f . toElt) r--  rangeToShape (low, high)-    = toElt (Repr.rangeToShape (fromElt low, fromElt high))-  shapeToRange ix-    = let (low, high) = Repr.shapeToRange (fromElt ix)-      in-      (toElt low, toElt high)--  shapeToList = Repr.shapeToList . fromElt-  listToShape = toElt . Repr.listToShape--instance Shape Z where-  sliceAnyIndex _ = Repr.SliceNil--instance Shape sh => Shape (sh:.Int) where-  sliceAnyIndex _ = Repr.SliceAll (sliceAnyIndex (undefined :: sh))---- | Slices, aka generalised indices, as /n/-tuples and mappings of slice--- indices to slices, co-slices, and slice dimensions----class (Elt sl, Shape (SliceShape sl), Shape (CoSliceShape sl), Shape (FullShape sl))-       => Slice sl where-  type SliceShape   sl :: *     -- the projected slice-  type CoSliceShape sl :: *     -- the complement of the slice-  type FullShape    sl :: *     -- the combined dimension-  sliceIndex :: sl {- dummy -} -> Repr.SliceIndex (EltRepr sl)-                                    (EltRepr (SliceShape   sl))-                                    (EltRepr (CoSliceShape sl))-                                    (EltRepr (FullShape    sl))--instance Slice Z where-  type SliceShape   Z = Z-  type CoSliceShape Z = Z-  type FullShape    Z = Z-  sliceIndex _ = Repr.SliceNil--instance Slice sl => Slice (sl:.All) where-  type SliceShape   (sl:.All) = SliceShape   sl :. Int-  type CoSliceShape (sl:.All) = CoSliceShape sl-  type FullShape    (sl:.All) = FullShape    sl :. Int-  sliceIndex _ = Repr.SliceAll (sliceIndex (undefined :: sl))--instance Slice sl => Slice (sl:.Int) where-  type SliceShape   (sl:.Int) = SliceShape   sl-  type CoSliceShape (sl:.Int) = CoSliceShape sl :. Int-  type FullShape    (sl:.Int) = FullShape    sl :. Int-  sliceIndex _ = Repr.SliceFixed (sliceIndex (undefined :: sl))--instance Shape sh => Slice (Any sh) where-  type SliceShape   (Any sh) = sh-  type CoSliceShape (Any sh) = Z-  type FullShape    (Any sh) = sh-  sliceIndex _ = sliceAnyIndex (undefined :: sh)----- Array operations--- -------------------- |Yield an array's shape----shape :: Shape sh => Array sh e -> sh-shape (Array sh _) = toElt sh---- |Array indexing----infixl 9 !-(!) :: Array sh e -> sh -> e-{-# INLINE (!) #-}--- (Array sh adata) ! ix = toElt (adata `indexArrayData` index sh ix)--- FIXME: using this due to a bug in 6.10.x-(!) (Array sh adata) ix = toElt (adata `unsafeIndexArrayData` toIndex (toElt sh) ix)---- |Create an array from its representation function----newArray :: (Shape sh, Elt e) => sh -> (sh -> e) -> Array sh e-{-# INLINE newArray #-}-newArray sh f = adata `seq` Array (fromElt sh) adata-  where-    (adata, _) = runArrayData $ do-                   arr <- newArrayData (size sh)-                   let write ix = unsafeWriteArrayData arr (toIndex sh ix)-                                                           (fromElt (f ix))-                   iter sh write (>>) (return ())-                   return (arr, undefined)---- | Creates a new, uninitialized Accelerate array.----allocateArray :: (Shape sh, Elt e) => sh -> IO (Array sh e)-{-# INLINE allocateArray #-}-allocateArray sh = adata `seq` return (Array (fromElt sh) adata)-  where-    (adata, _) = runArrayData $ (,undefined) `fmap` newArrayData (size sh)----- | Convert an 'IArray' to an accelerated array.------ While the type signature mentions Accelerate internals that are not exported,--- in practice satisfying the type equality is straight forward. The index type--- @ix@ must be the unit type @()@ for singleton arrays, or an @Int@ or tuple of--- @Int@'s for multidimensional arrays.----fromIArray :: (EltRepr ix ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix, Elt e)-           => a ix e -> Array sh e-fromIArray iarr = newArray (toElt sh) (\ix -> iarr IArray.! toElt (fromElt ix))-  where-    (lo,hi) = IArray.bounds iarr-    sh      = Repr.rangeToShape (fromElt lo, fromElt hi)---- | Convert an accelerated array to an 'IArray'.----toIArray :: (EltRepr ix ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix, Elt e)-         => Array sh e -> a ix e-toIArray arr = IArray.array bnds [(ix, arr ! toElt (fromElt ix)) | ix <- IArray.range bnds]-  where-    (lo,hi) = Repr.shapeToRange (fromElt (shape arr))-    bnds    = (toElt lo, toElt hi)---- | Convert a list, with elements in row-major order, into an accelerated array.----fromList :: (Shape sh, Elt e) => sh -> [e] -> Array sh e-{-# INLINE fromList #-}-fromList sh xs = adata `seq` Array (fromElt sh) adata-  where-    -- Assume the array is in dense row-major order. This is safe because-    -- otherwise backends would not be able to directly memcpy.-    ---    !n          = size sh-    (adata, _)  = runArrayData $ do-                    arr <- newArrayData n-                    let go !i _ | i >= n = return ()-                        go !i (v:vs)     = unsafeWriteArrayData arr i (fromElt v) >> go (i+1) vs-                        go _  []         = error "Data.Array.Accelerate.fromList: not enough input data"-                    ---                    go 0 xs-                    return (arr, undefined)---- | Convert an accelerated array to a list in row-major order.----toList :: forall sh e. Array sh e -> [e]-{-# INLINE toList #-}-toList (Array sh adata) = go 0-  where-    -- Assume underling array is in row-major order. This is safe because-    -- otherwise backends would not be able to directly memcpy.-    ---    !n                  = Repr.size sh-    go !i | i >= n      = []-          | otherwise   = toElt (adata `unsafeIndexArrayData` i) : go (i+1)---- Convert an array to a string----instance Show (Array sh e) where-  show arr@Array{}-    = "Array (" ++ showShape (shape arr) ++ ") " ++ show (toList arr)--instance Elt e => IsList (Vector e) where-  type Item (Vector e) = e-  toList         = toList-  fromListN n xs = fromList (Z:.n) xs-  fromList xs    = GHC.fromListN (length xs) xs--{----- Specialised Show instances for dimensions zero, one, and two. Requires--- overlapping instances.------ TODO:---   * Formatting of the matrix should be better, such as aligning the columns?---   * Make matrix formatting optional? It is more difficult to copy/paste the---     result, for example.----instance Show (Scalar e) where-  show arr@Array{}-    = "Scalar Z " ++ show (toList arr)--instance Show (Vector e) where-  show arr@Array{}-    = "Vector (" ++ showShape (shape arr) ++ ") " ++ show (toList arr)--instance Show (Array DIM2 e) where-  show arr@Array{}-    = "Array (" ++ showShape (shape arr) ++ ") \n " ++ showMat (toMatrix (toList arr))-    where-      showRow xs        = intercalate "," (map show xs)-      showMat mat       = "[" ++ intercalate "\n ," (map showRow mat) ++ "]"--      Z :. _ :. cols    = shape arr-      toMatrix []       = []-      toMatrix xs       = let (r,rs) = splitAt cols xs-                          in  r : toMatrix rs---}---- | Nicely format a shape as a string----showShape :: Shape sh => sh -> String-showShape = foldr (\sh str -> str ++ " :. " ++ show sh) "Z" . shapeToList+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}+#if __GLASGOW_HASKELL__ <= 708+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Array.Sugar+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+--               [2013..2017] Robert Clifton-Everest+--               [2014..2014] Frederik M. Madsen+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Array.Sugar (++  -- * Array representation+  Array(..), Scalar, Vector, Segments,+  Arrays(..), ArraysR(..), ArraysFlavour(..), ArrRepr,++  -- * Class of supported surface element types and their mapping to representation types+  Elt(..), EltRepr,++  -- * Derived functions+  liftToElt, liftToElt2, sinkFromElt, sinkFromElt2,++  -- * Array shapes+  DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9,++  -- * Array indexing and slicing+  Z(..), (:.)(..), All(..), Split(..), Any(..), Divide(..), Shape(..), Slice(..), Division(..),++  -- * Array shape query, indexing, and conversions+  shape, (!), allocateArray, fromFunction, fromList, toList, concatVectors,++  -- * Tuples+  TupleR, TupleRepr, tuple,+  Tuple(..), IsTuple, fromTuple, toTuple,+  Atuple(..), IsAtuple, fromAtuple, toAtuple,++  -- * Miscellaneous+  showShape, Foreign(..), sliceShape, enumSlices,++) where++-- standard library+import Control.DeepSeq+import Data.List                                                ( intercalate, transpose )+import Data.Typeable++import GHC.Exts                                                 ( IsList )+import qualified GHC.Exts                                       as GHC++-- friends+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Product+import qualified Data.Array.Accelerate.Array.Representation     as Repr+++-- Surface types representing array indices and slices+-- ---------------------------------------------------+--+-- Array indices are snoc type lists.  That is, they're backwards --+-- the end-of-list token, `Z`, occurs first.  For example, the type of a+-- rank-2 array index is @Z :. Int :. Int@.+--+-- In Accelerate the rightmost dimension is the /fastest varying/ or innermost.++-- |Rank-0 index+--+data Z = Z+  deriving (Typeable, Show, Eq)++-- |Increase an index rank by one dimension.  The `:.` operator is+--  used to construct both values and types.+--+infixl 3 :.+data tail :. head = tail :. head+  deriving (Typeable, Eq)++-- We don't we use a derived Show instance for (:.) because this will insert+-- parenthesis to demonstrate which order the operator is applied, i.e.:+--+--   (((Z :. z) :. y) :. x)+--+-- This is fine, but I find it a little unsightly. Instead, we drop all+-- parenthesis and just display the shape thus:+--+--   Z :. z :. y :. x+--+-- and then require the down-stream user to wrap the whole thing in parentheses.+-- This works fine for the most important case, which is to show Acc and Exp+-- expressions via the pretty printer, although Show-ing a Shape directly+-- results in no parenthesis being displayed.+--+-- One way around this might be to have specialised instances for DIM1, DIM2,+-- etc.+--+instance (Show sh, Show sz) => Show (sh :. sz) where+  show (sh :. sz) = show sh ++ " :. " ++ show sz++-- | Marker for entire dimensions in 'Data.Array.Accelerate.Language.slice' and+-- 'Data.Array.Accelerate.Language.replicate' descriptors.+--+-- Occurrences of 'All' indicate the dimensions into which the array's existing+-- extent will be placed unchanged.+--+-- See 'Data.Array.Accelerate.Language.slice' and+-- 'Data.Array.Accelerate.Language.replicate' for examples.+--+data All = All+  deriving (Typeable, Show, Eq)++-- | Marker for arbitrary dimensions in 'Data.Array.Accelerate.Language.slice'+-- and 'Data.Array.Accelerate.Language.replicate' descriptors.+--+-- 'Any' can be used in the leftmost position of a slice instead of 'Z',+-- indicating that any dimensionality is admissible in that position.+--+-- See 'Data.Array.Accelerate.Language.slice' and+-- 'Data.Array.Accelerate.Language.replicate' for examples.+--+data Any sh = Any+  deriving (Typeable, Show, Eq)++-- | Marker for splitting along an entire dimension in division descriptors.+--+-- For example, when used in a division descriptor passed to+-- 'Data.Array.Accelerate.toSeq', a `Split` indicates that the array should be+-- divided along this dimension forming the elements of the output sequence.+--+data Split = Split+  deriving (Typeable, Show, Eq)++-- | Marker for arbitrary shapes in slices descriptors, where it is desired to+-- split along an unknown number of dimensions.+--+-- For example, in the following definition, 'Divide' matches against any shape+-- and flattens everything but the innermost dimension.+--+-- > vectors :: (Shape sh, Elt e) => Acc (Array (sh:.Int) e) -> Seq [Vector e]+-- > vectors = toSeq (Divide :. All)+--+data Divide sh = Divide+  deriving (Typeable, Show, Eq)+++-- Representation change for array element types+-- ---------------------------------------------++-- | Type representation mapping+--+-- We represent tuples by using '()' and '(,)' as type-level nil and snoc to+-- construct snoc-lists of types, and are flattened all the way down to+-- primitive types.+--+type family EltRepr a :: *+type instance EltRepr ()              = ()+type instance EltRepr Z               = ()+type instance EltRepr (t:.h)          = (EltRepr t, EltRepr h)+type instance EltRepr All             = ()+type instance EltRepr (Any Z)         = ()+type instance EltRepr (Any (sh:.Int)) = (EltRepr (Any sh), ())+type instance EltRepr Int             = Int+type instance EltRepr Int8            = Int8+type instance EltRepr Int16           = Int16+type instance EltRepr Int32           = Int32+type instance EltRepr Int64           = Int64+type instance EltRepr Word            = Word+type instance EltRepr Word8           = Word8+type instance EltRepr Word16          = Word16+type instance EltRepr Word32          = Word32+type instance EltRepr Word64          = Word64+type instance EltRepr CShort          = CShort+type instance EltRepr CUShort         = CUShort+type instance EltRepr CInt            = CInt+type instance EltRepr CUInt           = CUInt+type instance EltRepr CLong           = CLong+type instance EltRepr CULong          = CULong+type instance EltRepr CLLong          = CLLong+type instance EltRepr CULLong         = CULLong+type instance EltRepr Float           = Float+type instance EltRepr Double          = Double+type instance EltRepr CFloat          = CFloat+type instance EltRepr CDouble         = CDouble+type instance EltRepr Bool            = Bool+type instance EltRepr Char            = Char+type instance EltRepr CChar           = CChar+type instance EltRepr CSChar          = CSChar+type instance EltRepr CUChar          = CUChar+type instance EltRepr (a, b)          = TupleRepr (EltRepr a, EltRepr b)+type instance EltRepr (a, b, c)       = TupleRepr (EltRepr a, EltRepr b, EltRepr c)+type instance EltRepr (a, b, c, d)    = TupleRepr (EltRepr a, EltRepr b, EltRepr c, EltRepr d)+type instance EltRepr (a, b, c, d, e) = TupleRepr (EltRepr a, EltRepr b, EltRepr c, EltRepr d, EltRepr e)+type instance EltRepr (a, b, c, d, e, f) = TupleRepr (EltRepr a, EltRepr b, EltRepr c, EltRepr d, EltRepr e, EltRepr f)+type instance EltRepr (a, b, c, d, e, f, g) = TupleRepr (EltRepr a, EltRepr b, EltRepr c, EltRepr d, EltRepr e, EltRepr f, EltRepr g)+type instance EltRepr (a, b, c, d, e, f, g, h) = TupleRepr (EltRepr a, EltRepr b, EltRepr c, EltRepr d, EltRepr e, EltRepr f, EltRepr g, EltRepr h)+type instance EltRepr (a, b, c, d, e, f, g, h, i) = TupleRepr (EltRepr a, EltRepr b, EltRepr c, EltRepr d, EltRepr e, EltRepr f, EltRepr g, EltRepr h, EltRepr i)+type instance EltRepr (a, b, c, d, e, f, g, h, i, j) = TupleRepr (EltRepr a, EltRepr b, EltRepr c, EltRepr d, EltRepr e, EltRepr f, EltRepr g, EltRepr h, EltRepr i, EltRepr j)+type instance EltRepr (a, b, c, d, e, f, g, h, i, j, k) = TupleRepr (EltRepr a, EltRepr b, EltRepr c, EltRepr d, EltRepr e, EltRepr f, EltRepr g, EltRepr h, EltRepr i, EltRepr j, EltRepr k)+type instance EltRepr (a, b, c, d, e, f, g, h, i, j, k, l) = TupleRepr (EltRepr a, EltRepr b, EltRepr c, EltRepr d, EltRepr e, EltRepr f, EltRepr g, EltRepr h, EltRepr i, EltRepr j, EltRepr k, EltRepr l)+type instance EltRepr (a, b, c, d, e, f, g, h, i, j, k, l, m) = TupleRepr (EltRepr a, EltRepr b, EltRepr c, EltRepr d, EltRepr e, EltRepr f, EltRepr g, EltRepr h, EltRepr i, EltRepr j, EltRepr k, EltRepr l, EltRepr m)+type instance EltRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = TupleRepr (EltRepr a, EltRepr b, EltRepr c, EltRepr d, EltRepr e, EltRepr f, EltRepr g, EltRepr h, EltRepr i, EltRepr j, EltRepr k, EltRepr l, EltRepr m, EltRepr n)+type instance EltRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = TupleRepr (EltRepr a, EltRepr b, EltRepr c, EltRepr d, EltRepr e, EltRepr f, EltRepr g, EltRepr h, EltRepr i, EltRepr j, EltRepr k, EltRepr l, EltRepr m, EltRepr n, EltRepr o)++type IsTuple = IsProduct Elt++fromTuple :: IsTuple tup => tup -> TupleRepr tup+fromTuple = fromProd (Proxy :: Proxy Elt)++toTuple :: IsTuple tup => TupleRepr tup -> tup+toTuple = toProd (Proxy :: Proxy Elt)+++-- Array elements (tuples of scalars)+-- ----------------------------------++-- | The 'Elt' class characterises the allowable array element types, and hence+-- the types which can appear in scalar Accelerate expressions.+--+-- Accelerate arrays consist of simple atomic types as well as nested tuples+-- thereof, stored efficiently in memory as consecutive unpacked elements+-- without pointers. It roughly consists of:+--+--  * Signed and unsigned integers (8, 16, 32, and 64-bits wide)+--  * Floating point numbers (single and double precision)+--  * 'Char'+--  * 'Bool'+--  * ()+--  * Shapes formed from 'Z' and (':.')+--  * Nested tuples of all of these, currently up to 15-elements wide+--+-- Adding new instances for 'Elt' consists of explaining to Accelerate how to+-- map between your data type and a (tuple of) primitive values. For examples+-- see:+--+--  * "Data.Array.Accelerate.Data.Complex"+--  * "Data.Array.Accelerate.Data.Monoid"+--  * <https://hackage.haskell.org/package/linear-accelerate linear-accelerate>+--  * <https://hackage.haskell.org/package/colour-accelerate colour-accelerate>+--+class (Show a, Typeable a, Typeable (EltRepr a), ArrayElt (EltRepr a))+      => Elt a where+  eltType  :: {-dummy-} a -> TupleType (EltRepr a)+  fromElt  :: a -> EltRepr a+  toElt    :: EltRepr a -> a++instance Elt () where+  eltType _ = UnitTuple+  fromElt   = id+  toElt     = id++instance Elt Z where+  eltType _  = UnitTuple+  fromElt Z  = ()+  toElt ()   = Z++instance (Elt t, Elt h) => Elt (t:.h) where+  eltType (_::(t:.h))   = PairTuple (eltType (undefined :: t)) (eltType (undefined :: h))+  fromElt (t:.h)        = (fromElt t, fromElt h)+  toElt (t, h)          = toElt t :. toElt h++instance Elt All where+  eltType _     = UnitTuple+  fromElt All   = ()+  toElt ()      = All++instance Elt (Any Z) where+  eltType _     = UnitTuple+  fromElt _     = ()+  toElt _       = Any++instance Shape sh => Elt (Any (sh:.Int)) where+  eltType _     = PairTuple (eltType (undefined::Any sh)) UnitTuple+  fromElt _     = (fromElt (undefined :: Any sh), ())+  toElt _       = Any++instance Elt Int where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Int8 where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Int16 where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Int32 where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Int64 where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Word where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Word8 where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Word16 where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Word32 where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Word64 where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CShort where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CUShort where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CInt where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CUInt where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CLong where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CULong where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CLLong where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CULLong where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Float where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Double where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CFloat where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CDouble where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Bool where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt Char where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CChar where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CSChar where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance Elt CUChar where+  eltType       = singletonScalarType+  fromElt       = id+  toElt         = id++instance (Elt a, Elt b) => Elt (a, b) where+  eltType _             = PairTuple (PairTuple UnitTuple (eltType (undefined::a))) (eltType (undefined::b))+  fromElt (a,b)         = (((), fromElt a), fromElt b)+  toElt (((),a),b)      = (toElt a, toElt b)++instance (Elt a, Elt b, Elt c) => Elt (a, b, c) where+  eltType _             = PairTuple (eltType (undefined :: (a, b))) (eltType (undefined :: c))+  fromElt (a, b, c)     = (fromElt (a, b), fromElt c)+  toElt (ab, c)         = let (a, b) = toElt ab in (a, b, toElt c)++instance (Elt a, Elt b, Elt c, Elt d) => Elt (a, b, c, d) where+  eltType _             = PairTuple (eltType (undefined :: (a, b, c))) (eltType (undefined :: d))+  fromElt (a, b, c, d)  = (fromElt (a, b, c), fromElt d)+  toElt (abc, d)        = let (a, b, c) = toElt abc in (a, b, c, toElt d)++instance (Elt a, Elt b, Elt c, Elt d, Elt e) => Elt (a, b, c, d, e) where+  eltType _               = PairTuple (eltType (undefined :: (a, b, c, d))) (eltType (undefined :: e))+  fromElt (a, b, c, d, e) = (fromElt (a, b, c, d), fromElt e)+  toElt (abcd, e)         = let (a, b, c, d) = toElt abcd in (a, b, c, d, toElt e)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) => Elt (a, b, c, d, e, f) where+  eltType _+    = PairTuple (eltType (undefined :: (a, b, c, d, e)))+                (eltType (undefined :: f))+  fromElt (a, b, c, d, e, f) = (fromElt (a, b, c, d, e), fromElt f)+  toElt (abcde, f) = let (a, b, c, d, e) = toElt abcde in (a, b, c, d, e, toElt f)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+  => Elt (a, b, c, d, e, f, g) where+  eltType _+    = PairTuple (eltType (undefined :: (a, b, c, d, e, f)))+                (eltType (undefined :: g))+  fromElt (a, b, c, d, e, f, g) = (fromElt (a, b, c, d, e, f), fromElt g)+  toElt (abcdef, g) = let (a, b, c, d, e, f) = toElt abcdef+                      in  (a, b, c, d, e, f, toElt g)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+  => Elt (a, b, c, d, e, f, g, h) where+  eltType _+    = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g)))+                (eltType (undefined :: h))+  fromElt (a, b, c, d, e, f, g, h) = (fromElt (a, b, c, d, e, f, g), fromElt h)+  toElt (abcdefg, h) = let (a, b, c, d, e, f, g) = toElt abcdefg+                       in  (a, b, c, d, e, f, g, toElt h)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+  => Elt (a, b, c, d, e, f, g, h, i) where+  eltType _+    = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h)))+                (eltType (undefined :: i))+  fromElt (a, b, c, d, e, f, g, h, i) = (fromElt (a, b, c, d, e, f, g, h), fromElt i)+  toElt (abcdefgh, i) = let (a, b, c, d, e, f, g, h) = toElt abcdefgh+                        in  (a, b, c, d, e, f, g, h, toElt i)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)+  => Elt (a, b, c, d, e, f, g, h, i, j) where+  eltType _+    = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h, i)))+                (eltType (undefined :: j))+  fromElt (a, b, c, d, e, f, g, h, i, j) = (fromElt (a, b, c, d, e, f, g, h, i), fromElt j)+  toElt (abcdefghi, j) = let (a, b, c, d, e, f, g, h, i) = toElt abcdefghi+                         in  (a, b, c, d, e, f, g, h, i, toElt j)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k)+  => Elt (a, b, c, d, e, f, g, h, i, j, k) where+  eltType _+    = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h, i, j)))+                (eltType (undefined :: k))+  fromElt (a, b, c, d, e, f, g, h, i, j, k) = (fromElt (a, b, c, d, e, f, g, h, i, j), fromElt k)+  toElt (abcdefghij, k) = let (a, b, c, d, e, f, g, h, i, j) = toElt abcdefghij+                          in  (a, b, c, d, e, f, g, h, i, j, toElt k)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l)+  => Elt (a, b, c, d, e, f, g, h, i, j, k, l) where+  eltType _+    = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h, i, j, k)))+                (eltType (undefined :: l))+  fromElt (a, b, c, d, e, f, g, h, i, j, k, l) = (fromElt (a, b, c, d, e, f, g, h, i, j, k), fromElt l)+  toElt (abcdefghijk, l) = let (a, b, c, d, e, f, g, h, i, j, k) = toElt abcdefghijk+                           in  (a, b, c, d, e, f, g, h, i, j, k, toElt l)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m)+  => Elt (a, b, c, d, e, f, g, h, i, j, k, l, m) where+  eltType _+    = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h, i, j, k, l)))+                (eltType (undefined :: m))+  fromElt (a, b, c, d, e, f, g, h, i, j, k, l, m) = (fromElt (a, b, c, d, e, f, g, h, i, j, k, l), fromElt m)+  toElt (abcdefghijkl, m) = let (a, b, c, d, e, f, g, h, i, j, k, l) = toElt abcdefghijkl+                            in  (a, b, c, d, e, f, g, h, i, j, k, l, toElt m)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m, Elt n)+  => Elt (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+  eltType _+    = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h, i, j, k, l, m)))+                (eltType (undefined :: n))+  fromElt (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = (fromElt (a, b, c, d, e, f, g, h, i, j, k, l, m), fromElt n)+  toElt (abcdefghijklm, n) = let (a, b, c, d, e, f, g, h, i, j, k, l, m) = toElt abcdefghijklm+                             in  (a, b, c, d, e, f, g, h, i, j, k, l, m, toElt n)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l, Elt m, Elt n, Elt o)+  => Elt (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+  eltType _+    = PairTuple (eltType (undefined :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n)))+                (eltType (undefined :: o))+  fromElt (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = (fromElt (a, b, c, d, e, f, g, h, i, j, k, l, m, n), fromElt o)+  toElt (abcdefghijklmn, o) = let (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = toElt abcdefghijklmn+                              in  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, toElt o)+++-- |Convenience functions+--++singletonScalarType :: IsScalar a => a -> TupleType a+singletonScalarType _ = SingleTuple scalarType++liftToElt :: (Elt a, Elt b)+          => (EltRepr a -> EltRepr b)+          -> (a -> b)+{-# INLINE liftToElt #-}+liftToElt f = toElt . f . fromElt++liftToElt2 :: (Elt a, Elt b, Elt c)+           => (EltRepr a -> EltRepr b -> EltRepr c)+           -> (a -> b -> c)+{-# INLINE liftToElt2 #-}+liftToElt2 f = \x y -> toElt $ f (fromElt x) (fromElt y)++sinkFromElt :: (Elt a, Elt b)+            => (a -> b)+            -> (EltRepr a -> EltRepr b)+{-# INLINE sinkFromElt #-}+sinkFromElt f = fromElt . f . toElt++sinkFromElt2 :: (Elt a, Elt b, Elt c)+             => (a -> b -> c)+             -> (EltRepr a -> EltRepr b -> EltRepr c)+{-# INLINE sinkFromElt2 #-}+sinkFromElt2 f = \x y -> fromElt $ f (toElt x) (toElt y)++-- {-# RULES+-- "fromElt/toElt" forall e. fromElt (toElt e) = e+-- "toElt/fromElt" forall e. toElt (fromElt e) = e+-- #-}+++-- Foreign functions+-- -----------------++-- Class for backends to choose their own representation of foreign functions.+-- By default it has no instances. If a backend wishes to have an FFI it must+-- provide an instance.+--+class Typeable asm => Foreign asm where++  -- Backends should be able to produce a string representation of the foreign+  -- function for pretty printing, typically the name of the function.+  strForeign :: asm args -> String+++-- Surface arrays+-- --------------++-- We represent tuples of arrays in the same way as tuples of scalars; using+-- '()' and '(,)' as type-level nil and snoc. This characterises the domain of+-- results of Accelerate array computations.+--+type family ArrRepr a :: *+type instance ArrRepr ()           = ()+type instance ArrRepr (Array sh e) = Array sh e+type instance ArrRepr (a, b)       = TupleRepr (ArrRepr a, ArrRepr b)+type instance ArrRepr (a, b, c)    = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c)+type instance ArrRepr (a, b, c, d) = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c, ArrRepr d)+type instance ArrRepr (a, b, c, d, e) = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c, ArrRepr d, ArrRepr e)+type instance ArrRepr (a, b, c, d, e, f) = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c, ArrRepr d, ArrRepr e, ArrRepr f)+type instance ArrRepr (a, b, c, d, e, f, g) = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c, ArrRepr d, ArrRepr e, ArrRepr f, ArrRepr g)+type instance ArrRepr (a, b, c, d, e, f, g, h) = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c, ArrRepr d, ArrRepr e, ArrRepr f, ArrRepr g, ArrRepr h)+type instance ArrRepr (a, b, c, d, e, f, g, h, i) = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c, ArrRepr d, ArrRepr e, ArrRepr f, ArrRepr g, ArrRepr h, ArrRepr i)+type instance ArrRepr (a, b, c, d, e, f, g, h, i, j) = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c, ArrRepr d, ArrRepr e, ArrRepr f, ArrRepr g, ArrRepr h, ArrRepr i, ArrRepr j)+type instance ArrRepr (a, b, c, d, e, f, g, h, i, j, k) = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c, ArrRepr d, ArrRepr e, ArrRepr f, ArrRepr g, ArrRepr h, ArrRepr i, ArrRepr j, ArrRepr k)+type instance ArrRepr (a, b, c, d, e, f, g, h, i, j, k, l) = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c, ArrRepr d, ArrRepr e, ArrRepr f, ArrRepr g, ArrRepr h, ArrRepr i, ArrRepr j, ArrRepr k, ArrRepr l)+type instance ArrRepr (a, b, c, d, e, f, g, h, i, j, k, l, m) = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c, ArrRepr d, ArrRepr e, ArrRepr f, ArrRepr g, ArrRepr h, ArrRepr i, ArrRepr j, ArrRepr k, ArrRepr l, ArrRepr m)+type instance ArrRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c, ArrRepr d, ArrRepr e, ArrRepr f, ArrRepr g, ArrRepr h, ArrRepr i, ArrRepr j, ArrRepr k, ArrRepr l, ArrRepr m, ArrRepr n)+type instance ArrRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = TupleRepr (ArrRepr a, ArrRepr b, ArrRepr c, ArrRepr d, ArrRepr e, ArrRepr f, ArrRepr g, ArrRepr h, ArrRepr i, ArrRepr j, ArrRepr k, ArrRepr l, ArrRepr m, ArrRepr n, ArrRepr o)++type IsAtuple = IsProduct Arrays++fromAtuple :: IsAtuple tup => tup -> TupleRepr tup+fromAtuple = fromProd (Proxy :: Proxy Arrays)++toAtuple :: IsAtuple tup => TupleRepr tup -> tup+toAtuple = toProd (Proxy :: Proxy Arrays)++-- Array type reification+--+data ArraysR arrs where+  ArraysRunit  ::                                   ArraysR ()+  ArraysRarray :: (Shape sh, Elt e) =>              ArraysR (Array sh e)+  ArraysRpair  :: ArraysR arrs1 -> ArraysR arrs2 -> ArraysR (arrs1, arrs2)++data ArraysFlavour arrs where+  ArraysFunit  ::                                          ArraysFlavour ()+  ArraysFarray :: (Shape sh, Elt e)                     => ArraysFlavour (Array sh e)+  ArraysFtuple :: (IsAtuple arrs, ArrRepr arrs ~ (l,r)) => ArraysFlavour arrs++-- | 'Arrays' consists of nested tuples of individual 'Array's, currently up to+-- 15-elements wide. Accelerate computations can thereby return multiple+-- results.+--+class (Typeable a, Typeable (ArrRepr a)) => Arrays a where+  arrays   :: a {- dummy -} -> ArraysR (ArrRepr a)+  flavour  :: a {- dummy -} -> ArraysFlavour a+  --+  toArr    :: ArrRepr  a -> a+  fromArr  :: a -> ArrRepr  a+++instance Arrays () where+  arrays  _ = ArraysRunit+  flavour _ = ArraysFunit+  --+  toArr     = id+  fromArr   = id++instance (Shape sh, Elt e) => Arrays (Array sh e) where+  arrays _      = ArraysRarray+  flavour _     = ArraysFarray+  --+  toArr         = id+  fromArr       = id++instance (Arrays a, Arrays b) => Arrays (a, b) where+  arrays  _             = ArraysRpair (ArraysRpair ArraysRunit (arrays (undefined::a))) (arrays (undefined::b))+  flavour _             = ArraysFtuple+  --+  toArr    (((),a), b)  = (toArr a, toArr b)+  fromArr  (a, b)       = (((), fromArr a), fromArr b)++instance (Arrays a, Arrays b, Arrays c) => Arrays (a, b, c) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b))) (arrays (undefined::c))+  flavour _             = ArraysFtuple+  --+  toArr    (ab, c)      = let (a, b) = toArr ab in (a, b, toArr c)+  fromArr  (a, b, c)    = (fromArr (a, b), fromArr c)++instance (Arrays a, Arrays b, Arrays c, Arrays d) => Arrays (a, b, c, d) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c))) (arrays (undefined::d))+  flavour _             = ArraysFtuple+  --+  toArr    (abc, d)     = let (a, b, c) = toArr abc in (a, b, c, toArr d)+  fromArr  (a, b, c, d) = (fromArr (a, b, c), fromArr d)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e) => Arrays (a, b, c, d, e) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c, d))) (arrays (undefined::e))+  flavour _             = ArraysFtuple+  --+  toArr    (abcd, e)    = let (a, b, c, d) = toArr abcd in (a, b, c, d, toArr e)+  fromArr  (a, b, c, d, e) = (fromArr (a, b, c, d), fromArr e)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)+  => Arrays (a, b, c, d, e, f) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c, d, e))) (arrays (undefined::f))+  flavour _             = ArraysFtuple+  --+  toArr    (abcde, f)   = let (a, b, c, d, e) = toArr abcde in (a, b, c, d, e, toArr f)+  fromArr  (a, b, c, d, e, f) = (fromArr (a, b, c, d, e), fromArr f)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)+  => Arrays (a, b, c, d, e, f, g) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c, d, e, f))) (arrays (undefined::g))+  flavour _             = ArraysFtuple+  --+  toArr    (abcdef, g)   = let (a, b, c, d, e, f) = toArr abcdef in (a, b, c, d, e, f, toArr g)+  fromArr  (a, b, c, d, e, f, g) = (fromArr (a, b, c, d, e, f), fromArr g)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)+  => Arrays (a, b, c, d, e, f, g, h) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c, d, e, f, g))) (arrays (undefined::h))+  flavour _             = ArraysFtuple+  --+  toArr    (abcdefg, h)   = let (a, b, c, d, e, f, g) = toArr abcdefg in (a, b, c, d, e, f, g, toArr h)+  fromArr  (a, b, c, d, e, f, g, h) = (fromArr (a, b, c, d, e, f, g), fromArr h)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)+  => Arrays (a, b, c, d, e, f, g, h, i) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c, d, e, f, g, h))) (arrays (undefined::i))+  flavour _             = ArraysFtuple+  --+  toArr    (abcdefgh, i) = let (a, b, c, d, e, f, g, h) = toArr abcdefgh in (a, b, c, d, e, f, g, h, toArr i)+  fromArr  (a, b, c, d, e, f, g, h, i) = (fromArr (a, b, c, d, e, f, g, h), fromArr i)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j)+  => Arrays (a, b, c, d, e, f, g, h, i, j) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c, d, e, f, g, h, i))) (arrays (undefined::j))+  flavour _             = ArraysFtuple+  --+  toArr    (abcdefghi, j) = let (a, b, c, d, e, f, g, h, i) = toArr abcdefghi in (a, b, c, d, e, f, g, h, i, toArr j)+  fromArr  (a, b, c, d, e, f, g, h, i, j) = (fromArr (a, b, c, d, e, f, g, h, i), fromArr j)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k)+  => Arrays (a, b, c, d, e, f, g, h, i, j, k) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c, d, e, f, g, h, i, j))) (arrays (undefined::k))+  flavour _             = ArraysFtuple+  --+  toArr    (abcdefghij, k) = let (a, b, c, d, e, f, g, h, i, j) = toArr abcdefghij in (a, b, c, d, e, f, g, h, i, j, toArr k)+  fromArr  (a, b, c, d, e, f, g, h, i, j, k) = (fromArr (a, b, c, d, e, f, g, h, i, j), fromArr k)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l)+  => Arrays (a, b, c, d, e, f, g, h, i, j, k, l) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c, d, e, f, g, h, i, j, k))) (arrays (undefined::l))+  flavour _             = ArraysFtuple+  --+  toArr    (abcdefghijk, l) = let (a, b, c, d, e, f, g, h, i, j, k) = toArr abcdefghijk in (a, b, c, d, e, f, g, h, i, j, k, toArr l)+  fromArr  (a, b, c, d, e, f, g, h, i, j, k, l) = (fromArr (a, b, c, d, e, f, g, h, i, j, k), fromArr l)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m)+  => Arrays (a, b, c, d, e, f, g, h, i, j, k, l, m) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c, d, e, f, g, h, i, j, k, l))) (arrays (undefined::m))+  flavour _             = ArraysFtuple+  --+  toArr    (abcdefghijkl, m) = let (a, b, c, d, e, f, g, h, i, j, k, l) = toArr abcdefghijkl in (a, b, c, d, e, f, g, h, i, j, k, l, toArr m)+  fromArr  (a, b, c, d, e, f, g, h, i, j, k, l, m) = (fromArr (a, b, c, d, e, f, g, h, i, j, k, l), fromArr m)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n)+  => Arrays (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c, d, e, f, g, h, i, j, k, l, m))) (arrays (undefined::n))+  flavour _             = ArraysFtuple+  --+  toArr    (abcdefghijklm, n) = let (a, b, c, d, e, f, g, h, i, j, k, l, m) = toArr abcdefghijklm in (a, b, c, d, e, f, g, h, i, j, k, l, m, toArr n)+  fromArr  (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = (fromArr (a, b, c, d, e, f, g, h, i, j, k, l, m), fromArr n)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l, Arrays m, Arrays n, Arrays o)+  => Arrays (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n))) (arrays (undefined::o))+  flavour _             = ArraysFtuple+  --+  toArr    (abcdefghijklmn, o) = let (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = toArr abcdefghijklmn in (a, b, c, d, e, f, g, h, i, j, k, l, m, n, toArr o)+  fromArr  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = (fromArr (a, b, c, d, e, f, g, h, i, j, k, l, m, n), fromArr o)+++-- {-# RULES+-- "fromArr/toArr" forall a. fromArr (toArr a) = a+-- "toArr/fromArr" forall a. toArr (fromArr a) = a+-- #-}+++-- Tuple representation+-- --------------------++-- |The tuple representation is equivalent to the product representation.+--+type TupleRepr a = ProdRepr a++-- |We represent tuples as heterogeneous lists, typed by a type list.+--+data Tuple c t where+  NilTup  ::                              Tuple c ()+  SnocTup :: Elt t => Tuple c s -> c t -> Tuple c (s, t)++-- TLM: It is irritating that we need a separate data type for tuples of scalars+--   vs. arrays, purely to carry the class constraint.+--+-- | Tuples of Arrays.  Note that this carries the `Arrays` class+--   constraint rather than `Elt` in the case of tuples of scalars.+--+data Atuple c t where+  NilAtup  ::                                  Atuple c ()+  SnocAtup :: Arrays a => Atuple c s -> c a -> Atuple c (s, a)++-- |Tuple reification+--+type TupleR a = ProdR Elt a++tuple :: IsTuple tup => {- dummy -} tup -> TupleR (TupleRepr tup)+tuple = prod (Proxy :: Proxy Elt)+++-- | Dense, regular, multi-dimensional arrays.+--+-- The 'Array' is the core computational unit of Accelerate; all programs in+-- Accelerate take zero or more arrays as input and produce one or more arrays+-- as output. The 'Array' type has two type parameters:+--+--  * /sh/: is the shape of the array, tracking the dimensionality and extent of+--    each dimension of the array; for example, 'DIM1' for one-dimensional+--    'Vector's, 'DIM2' for two-dimensional matrices, and so on.+--  * /e/: represents the type of each element of the array; for example,+--    'Int', 'Float', et cetera.+--+-- Array data is store unboxed in an unzipped struct-of-array representation.+-- Elements are laid out in row-major order (the right-most index of a 'Shape'+-- is the fastest varying). The allowable array element types are members of the+-- 'Elt' class, which roughly consists of:+--+--  * Signed and unsigned integers (8, 16, 32, and 64-bits wide).+--  * Floating point numbers (single and double precision)+--  * 'Char'+--  * 'Bool'+--  * ()+--  * Shapes formed from 'Z' and (':.')+--  * Nested tuples of all of these, currently up to 15-elements wide.+--+-- Note that 'Array' itself is not an allowable element type---there are no+-- nested arrays in Accelerate, regular arrays only!+--+-- If device and host memory are separate, arrays will be transferred to the+-- device when necessary (possibly asynchronously and in parallel with other+-- tasks) and cached on the device if sufficient memory is available. Arrays are+-- made available to embedded language computations via+-- 'Data.Array.Accelerate.use'.+--+-- Section "Getting data in" lists functions for getting data into and out of+-- the 'Array' type.+--+data Array sh e where+  Array :: (Shape sh, Elt e)+        => EltRepr sh                 -- extent of dimensions = shape+        -> ArrayData (EltRepr e)      -- array payload+        -> Array sh e++deriving instance Typeable Array++instance (Eq sh, Eq e) => Eq (Array sh e) where+  arr1@Array{} == arr2@Array{} = shape arr1 == shape arr2 && toList arr1 == toList arr2+  arr1@Array{} /= arr2@Array{} = shape arr1 /= shape arr2 || toList arr1 /= toList arr2++#if __GLASGOW_HASKELL__ >= 710+-- Convert an array to a string, using specialised instances for dimensions+-- zero, one, and two. These are available for ghc-7.10 and later only (earlier+-- versions of ghc would require -XIncoherentInstances in the client module).+--+-- TODO:+--   * Make special formatting optional? It is more difficult to copy/paste the+--     result, for example. Also it does not look good if the matrix row does+--     not fit on a single line.+--   * The AST pretty printer does not use these instances+--+instance Show (Scalar e) where+  show arr@Array{} =+    "Scalar Z " ++ show (toList arr)++instance Show (Vector e) where+  show arr@Array{} =+    "Vector (" ++ showShape (shape arr) ++ ") " ++ show (toList arr)++instance Show (Array DIM2 e) where+  show arr@Array{} =+    "Matrix (" ++ showShape (shape arr) ++ ") " ++ showMat (toMatrix (toList arr))+    where+      Z :. _ :. cols    = shape arr+      toMatrix []       = []+      toMatrix xs       = let (r,rs) = splitAt cols xs+                          in  r : toMatrix rs+      --+      showMat []        = "[]"+      showMat mat       = "\n  " ++ ppMat (map (map show) mat)+      --+      ppRow row         = concatMap (++",") row+      ppMat mat         = "[" ++ init (intercalate "\n   " (map ppRow (ppColumns mat))) ++ "]"+      ppColumns         = transpose . map (\col -> pad (width col) col) . transpose+        where+          extra = 0+          width = maximum . map length+          pad w = map (\x -> replicate (w - length x + extra) ' ' ++ x)+#endif++-- This is a bit unfortunate, but we need to use an INCOHERENT instance because+-- GHC can't determine that with the above specialisations, a DIM3+ instance+-- covers all remaining possibilities, and lacking a general instance is+-- problematic for operations which want a 'Show (Array sh e)' constraint.+-- Furthermore, those clients are likely to pick this instance, rather than the+-- more specific ones above, which is (perhaps) a little unfortunate.+--+instance {-# INCOHERENT #-} Show (Array sh e) where+  show arr@Array{} =+    "Array (" ++ showShape (shape arr) ++ ") " ++ show (toList arr)++instance Elt e => IsList (Vector e) where+  type Item (Vector e) = e+  toList         = toList+  fromListN n xs = fromList (Z:.n) xs+  fromList xs    = GHC.fromListN (length xs) xs++instance NFData (Array sh e) where+  rnf (Array sh ad) = Repr.size sh `seq` go arrayElt ad `seq` ()+    where+      go :: ArrayEltR e' -> ArrayData e' -> ()+      go ArrayEltRunit         AD_Unit         = ()+      go ArrayEltRint          (AD_Int ua)     = rnf ua+      go ArrayEltRint8         (AD_Int8 ua)    = rnf ua+      go ArrayEltRint16        (AD_Int16 ua)   = rnf ua+      go ArrayEltRint32        (AD_Int32 ua)   = rnf ua+      go ArrayEltRint64        (AD_Int64 ua)   = rnf ua+      go ArrayEltRword         (AD_Word ua)    = rnf ua+      go ArrayEltRword8        (AD_Word8 ua)   = rnf ua+      go ArrayEltRword16       (AD_Word16 ua)  = rnf ua+      go ArrayEltRword32       (AD_Word32 ua)  = rnf ua+      go ArrayEltRword64       (AD_Word64 ua)  = rnf ua+      go ArrayEltRcshort       (AD_CShort ua)  = rnf ua+      go ArrayEltRcushort      (AD_CUShort ua) = rnf ua+      go ArrayEltRcint         (AD_CInt ua)    = rnf ua+      go ArrayEltRcuint        (AD_CUInt ua)   = rnf ua+      go ArrayEltRclong        (AD_CLong ua)   = rnf ua+      go ArrayEltRculong       (AD_CULong ua)  = rnf ua+      go ArrayEltRcllong       (AD_CLLong ua)  = rnf ua+      go ArrayEltRcullong      (AD_CULLong ua) = rnf ua+      go ArrayEltRfloat        (AD_Float ua)   = rnf ua+      go ArrayEltRdouble       (AD_Double ua)  = rnf ua+      go ArrayEltRcfloat       (AD_CFloat ua)  = rnf ua+      go ArrayEltRcdouble      (AD_CDouble ua) = rnf ua+      go ArrayEltRbool         (AD_Bool ua)    = rnf ua+      go ArrayEltRchar         (AD_Char ua)    = rnf ua+      go ArrayEltRcchar        (AD_CChar ua)   = rnf ua+      go ArrayEltRcschar       (AD_CSChar ua)  = rnf ua+      go ArrayEltRcuchar       (AD_CUChar ua)  = rnf ua+      go (ArrayEltRpair r1 r2) (AD_Pair a1 a2) = go r1 a1 `seq` go r2 a2 `seq` ()++-- |Scalars arrays hold a single element+--+type Scalar e = Array DIM0 e++-- |Vectors are one-dimensional arrays+--+type Vector e = Array DIM1 e++-- |Segment descriptor (vector of segment lengths).+--+-- To represent nested one-dimensional arrays, we use a flat array of data+-- values in conjunction with a /segment descriptor/, which stores the lengths+-- of the subarrays.+--+type Segments i = Vector i++-- Shorthand for common shape types+--+type DIM0 = Z+type DIM1 = DIM0:.Int+type DIM2 = DIM1:.Int+type DIM3 = DIM2:.Int+type DIM4 = DIM3:.Int+type DIM5 = DIM4:.Int+type DIM6 = DIM5:.Int+type DIM7 = DIM6:.Int+type DIM8 = DIM7:.Int+type DIM9 = DIM8:.Int+++-- Shape constraints and indexing+-- ------------------------------++-- |Shapes and indices of multi-dimensional arrays+--+class (Elt sh, Elt (Any sh), Repr.Shape (EltRepr sh), FullShape sh ~ sh, CoSliceShape sh ~ sh, SliceShape sh ~ Z)+       => Shape sh where++  -- |Number of dimensions of a /shape/ or /index/ (>= 0).+  rank   :: sh -> Int++  -- |Total number of elements in an array of the given /shape/.+  size   :: sh -> Int++  -- |Empty /shape/.+  empty :: sh++  -- |Magic value identifying elements ignored in 'permute'.+  ignore :: sh++  -- |Yield the intersection of two shapes+  intersect :: sh -> sh -> sh++  -- |Yield the union of two shapes+  union :: sh -> sh -> sh++  -- |Map a multi-dimensional index into one in a linear, row-major+  -- representation of the array (first argument is the /shape/, second+  -- argument is the index).+  toIndex   :: sh -> sh -> Int++  -- |Inverse of 'toIndex'.+  fromIndex :: sh -> Int -> sh++  -- |Apply a boundary condition to an index.+  bound  :: sh -> sh -> Boundary a -> Either a sh++  -- |Iterate through the entire shape, applying the function; third argument+  -- combines results and fourth is returned in case of an empty iteration+  -- space; the index space is traversed in row-major order.+  iter  :: sh -> (sh -> a) -> (a -> a -> a) -> a -> a++  -- |Variant of 'iter' without an initial value+  iter1 :: sh -> (sh -> a) -> (a -> a -> a) -> a++  -- |Convert a minpoint-maxpoint index into a /shape/.+  rangeToShape ::  (sh, sh) -> sh++  -- |Convert a /shape/ into a minpoint-maxpoint index.+  shapeToRange ::  sh -> (sh, sh)++  -- |Convert a shape to a list of dimensions.+  shapeToList :: sh -> [Int]++  -- |Convert a list of dimensions into a shape.+  listToShape :: [Int] -> sh++  -- | The slice index for slice specifier 'Any sh'+  sliceAnyIndex :: sh -> Repr.SliceIndex (EltRepr (Any sh)) (EltRepr sh) () (EltRepr sh)++  -- | The slice index for specifying a slice with only the Z component projected+  sliceNoneIndex :: sh -> Repr.SliceIndex (EltRepr sh) () (EltRepr sh) (EltRepr sh)++  rank                  = Repr.rank . fromElt+  size                  = Repr.size . fromElt+  empty                 = toElt Repr.empty+  -- (#) must be individually defined, as it holds for all instances *except*+  -- the one with the largest arity++  ignore                = toElt Repr.ignore+  intersect sh1 sh2     = toElt (Repr.intersect (fromElt sh1) (fromElt sh2))+  union sh1 sh2         = toElt (Repr.union (fromElt sh1) (fromElt sh2))+  fromIndex sh ix       = toElt (Repr.fromIndex (fromElt sh) ix)+  toIndex sh ix         = Repr.toIndex (fromElt sh) (fromElt ix)++  bound sh ix bndy      = case Repr.bound (fromElt sh) (fromElt ix) bndy of+                            Left v    -> Left v+                            Right ix' -> Right $ toElt ix'++  iter sh f c r         = Repr.iter  (fromElt sh) (f . toElt) c r+  iter1 sh f r          = Repr.iter1 (fromElt sh) (f . toElt) r++  rangeToShape (low, high)+    = toElt (Repr.rangeToShape (fromElt low, fromElt high))+  shapeToRange ix+    = let (low, high) = Repr.shapeToRange (fromElt ix)+      in+      (toElt low, toElt high)++  shapeToList = Repr.shapeToList . fromElt+  listToShape = toElt . Repr.listToShape++instance Shape Z where+  sliceAnyIndex  _ = Repr.SliceNil+  sliceNoneIndex _ = Repr.SliceNil++instance Shape sh => Shape (sh:.Int) where+  sliceAnyIndex  _ = Repr.SliceAll   (sliceAnyIndex  (undefined :: sh))+  sliceNoneIndex _ = Repr.SliceFixed (sliceNoneIndex (undefined :: sh))++-- | Slices, aka generalised indices, as /n/-tuples and mappings of slice+-- indices to slices, co-slices, and slice dimensions+--+class (Elt sl, Shape (SliceShape sl), Shape (CoSliceShape sl), Shape (FullShape sl))+       => Slice sl where+  type SliceShape   sl :: *     -- the projected slice+  type CoSliceShape sl :: *     -- the complement of the slice+  type FullShape    sl :: *     -- the combined dimension+  sliceIndex :: sl {- dummy -} -> Repr.SliceIndex (EltRepr sl)+                                    (EltRepr (SliceShape   sl))+                                    (EltRepr (CoSliceShape sl))+                                    (EltRepr (FullShape    sl))++instance Slice Z where+  type SliceShape   Z = Z+  type CoSliceShape Z = Z+  type FullShape    Z = Z+  sliceIndex _ = Repr.SliceNil++instance Slice sl => Slice (sl:.All) where+  type SliceShape   (sl:.All) = SliceShape   sl :. Int+  type CoSliceShape (sl:.All) = CoSliceShape sl+  type FullShape    (sl:.All) = FullShape    sl :. Int+  sliceIndex _ = Repr.SliceAll (sliceIndex (undefined :: sl))++instance Slice sl => Slice (sl:.Int) where+  type SliceShape   (sl:.Int) = SliceShape   sl+  type CoSliceShape (sl:.Int) = CoSliceShape sl :. Int+  type FullShape    (sl:.Int) = FullShape    sl :. Int+  sliceIndex _ = Repr.SliceFixed (sliceIndex (undefined :: sl))++instance Shape sh => Slice (Any sh) where+  type SliceShape   (Any sh) = sh+  type CoSliceShape (Any sh) = Z+  type FullShape    (Any sh) = sh+  sliceIndex _ = sliceAnyIndex (undefined :: sh)+++-- | Generalised array division, like above but use for splitting an array into+-- many subarrays, as opposed to extracting a single subarray.+--+class (Slice (DivisionSlice sl))+       => Division sl where+  type DivisionSlice sl :: *     -- the slice+  slicesIndex :: slix ~ DivisionSlice sl+              => sl {- dummy -}+              -> Repr.SliceIndex (EltRepr slix)+                                 (EltRepr (SliceShape   slix))+                                 (EltRepr (CoSliceShape slix))+                                 (EltRepr (FullShape    slix))++instance Division Z where+  type DivisionSlice   Z = Z+  slicesIndex _ = Repr.SliceNil++instance Division sl => Division (sl:.All) where+  type DivisionSlice  (sl:.All) = DivisionSlice sl :. All+  slicesIndex _ = Repr.SliceAll (slicesIndex (undefined :: sl))++instance Division sl => Division (sl:.Split) where+  type DivisionSlice (sl:.Split) = DivisionSlice sl :. Int+  slicesIndex _ = Repr.SliceFixed (slicesIndex (undefined :: sl))++instance Shape sh => Division (Any sh) where+  type DivisionSlice (Any sh) = Any sh+  slicesIndex _ = sliceAnyIndex (undefined :: sh)++instance (Shape sh, Slice sh) => Division (Divide sh) where+  type DivisionSlice (Divide sh) = sh+  slicesIndex _ = sliceNoneIndex (undefined :: sh)+++-- Array operations+-- ----------------++-- |Yield an array's shape+--+shape :: Shape sh => Array sh e -> sh+shape (Array sh _) = toElt sh++-- | Array indexing+--+infixl 9 !+(!) :: Array sh e -> sh -> e+{-# INLINE (!) #-}+-- (Array sh adata) ! ix = toElt (adata `indexArrayData` index sh ix)+-- FIXME: using this due to a bug in 6.10.x+(!) (Array sh adata) ix = toElt (adata `unsafeIndexArrayData` toIndex (toElt sh) ix)++-- | Create an array from its representation function, applied at each index of+-- the array.+--+fromFunction :: (Shape sh, Elt e) => sh -> (sh -> e) -> Array sh e+{-# INLINE fromFunction #-}+fromFunction sh f = adata `seq` Array (fromElt sh) adata+  where+    (adata, _) = runArrayData $ do+                   arr <- newArrayData (size sh)+                   let write ix = unsafeWriteArrayData arr (toIndex sh ix)+                                                           (fromElt (f ix))+                   iter sh write (>>) (return ())+                   return (arr, undefined)+++-- | Create a vector from the concatenation of the given list of vectors.+--+concatVectors :: Elt e => [Vector e] -> Vector e+{-# INLINE concatVectors #-}+concatVectors vs = adata `seq` Array ((), len) adata+  where+    offsets     = scanl (+) 0 (map (size . shape) vs)+    len         = last offsets+    (adata, _)  = runArrayData $ do+              arr <- newArrayData len+              sequence_ [ unsafeWriteArrayData arr (i + k) (unsafeIndexArrayData ad i)+                        | (Array ((), n) ad, k) <- vs `zip` offsets+                        , i <- [0 .. n - 1] ]+              return (arr, undefined)++-- | Creates a new, uninitialized Accelerate array.+--+allocateArray :: (Shape sh, Elt e) => sh -> IO (Array sh e)+{-# INLINE allocateArray #-}+allocateArray sh = adata `seq` return (Array (fromElt sh) adata)+  where+    (adata, _) = runArrayData $ (,undefined) `fmap` newArrayData (size sh)+++-- | Convert elements of a list into an Accelerate 'Array'.+--+-- This will generate a new multidimensional 'Array' of the specified shape and+-- extent by consuming elements from the list and adding them to the array in+-- row-major order.+--+-- >>> fromList (Z:.10) [0..] :: Vector Int+-- Vector (Z :. 10) [0,1,2,3,4,5,6,7,8,9]+--+-- Note that we pull elements off the list lazily, so infinite lists are+-- accepted:+--+-- >>> fromList (Z:.5:.10) (repeat 0) :: Array DIM2 Float+-- Matrix (Z :. 5 :. 10)+--   [ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,+--     0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,+--     0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,+--     0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,+--     0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0]+--+-- You can also make use of the @OverloadedLists@ extension to produce+-- one-dimensional vectors from a /finite/ list.+--+-- >>> [0..9] :: Vector Int+-- Vector (Z :. 10) [0,1,2,3,4,5,6,7,8,9]+--+-- Note that this requires first traversing the list to determine its length,+-- and then traversing it a second time to collect the elements into the array,+-- thus forcing the spine of the list to be manifest on the heap.+--+fromList :: (Shape sh, Elt e) => sh -> [e] -> Array sh e+{-# INLINE fromList #-}+fromList sh xs = adata `seq` Array (fromElt sh) adata+  where+    -- Assume the array is in dense row-major order. This is safe because+    -- otherwise backends would not be able to directly memcpy.+    --+    !n          = size sh+    (adata, _)  = runArrayData $ do+                    arr <- newArrayData n+                    let go !i _ | i >= n = return ()+                        go !i (v:vs)     = unsafeWriteArrayData arr i (fromElt v) >> go (i+1) vs+                        go _  []         = error "Data.Array.Accelerate.fromList: not enough input data"+                    --+                    go 0 xs+                    return (arr, undefined)++-- | Convert an accelerated 'Array' to a list in row-major order.+--+toList :: forall sh e. Array sh e -> [e]+{-# INLINE toList #-}+toList (Array sh adata) = go 0+  where+    -- Assume underling array is in row-major order. This is safe because+    -- otherwise backends would not be able to directly memcpy.+    --+    !n                  = Repr.size sh+    go !i | i >= n      = []+          | otherwise   = toElt (adata `unsafeIndexArrayData` i) : go (i+1)++-- | Nicely format a shape as a string+--+showShape :: Shape sh => sh -> String+showShape = foldr (\sh str -> str ++ " :. " ++ show sh) "Z" . shapeToList++-- | Project the shape of a slice from the full shape.+--+sliceShape :: forall slix co sl dim. (Shape sl, Shape dim)+           => Repr.SliceIndex slix (EltRepr sl) co (EltRepr dim)+           -> dim+           -> sl+sliceShape slix = toElt . Repr.sliceShape slix . fromElt++-- | Enumerate all slices within a given bound. The innermost dimension+-- changes most rapidly.+--+-- Example:+--+-- > let slix = sliceIndex (undefined :: Z :. Int :. Int :. All)+-- >     sh   = Z :. 2 :. 3 :. 1 :: DIM3+-- > in+-- > enumSlices slix sh :: [ Z :. Int :. Int :. All ]+--+enumSlices :: forall slix co sl dim. (Elt slix, Elt dim)+           => Repr.SliceIndex (EltRepr slix) sl co (EltRepr dim)+           -> dim    -- Bounds+           -> [slix] -- All slices within bounds.+enumSlices slix = map toElt . Repr.enumSlices slix . fromElt